X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=79f59730a97f1238ecc5ca8ad0db42fa487bd9c6;hb=b9ba2fadb18b54e35e5de54f945111a56cbcb249;hp=a8a5fd15a0f9285612445bfa3725552020b08f85;hpb=04fe65b0c880322a5ab5677fef6303b6149b8676;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index a8a5fd1..79f5973 100644 --- a/hv.c +++ b/hv.c @@ -1,7 +1,7 @@ /* hv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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"] */ /* @@ -40,8 +44,11 @@ STATIC void S_more_he(pTHX) { dVAR; - HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT); - HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1]; + /* We could generate this at compile time via (another) auxiliary C + program? */ + const size_t arena_size = Perl_malloc_good_size(PERL_ARENA_SIZE); + HE* he = (HE*) Perl_get_arena(aTHX_ arena_size, HE_SVSLOT); + HE * const heend = &he[arena_size / sizeof(HE) - 1]; PL_body_roots[HE_SVSLOT] = he; while (he < heend) { @@ -91,6 +98,8 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) char *k; register HEK *hek; + PERL_ARGS_ASSERT_SAVE_HEK_FLAGS; + Newx(k, HEK_BASESIZE + len + 2, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); @@ -127,6 +136,7 @@ Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) { HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + PERL_ARGS_ASSERT_HEK_DUP; PERL_UNUSED_ARG(param); if (shared) { @@ -147,6 +157,8 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) { HE *ret; + PERL_ARGS_ASSERT_HE_DUP; + if (!e) return NULL; /* look for it in the table first */ @@ -161,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)); } @@ -196,6 +208,9 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) { SV * const sv = sv_newmortal(); + + PERL_ARGS_ASSERT_HV_NOTALLOWED; + if (!(flags & HVhek_FREEKEY)) { sv_setpvn(sv, key, klen); } @@ -312,6 +327,8 @@ Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, STRLEN klen; int flags; + PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; + if (klen_i32 < 0) { klen = -klen_i32; flags = HVhek_UTF8; @@ -344,20 +361,20 @@ 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; if (!keysv) { - keysv = sv_2mortal(newSVpvn(key, klen)); - if (flags & HVhek_UTF8) - SvUTF8_on(keysv); + keysv = newSVpvn_flags(key, klen, SVs_TEMP | + ((flags & HVhek_UTF8) + ? SVf_UTF8 : 0)); } 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; @@ -371,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); } @@ -386,20 +407,18 @@ 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. */ if (!keysv) { - keysv = newSVpvn(key, klen); - if (is_utf8) { - SvUTF8_on(keysv); - } - } else { + keysv = newSVpvn_utf8(key, klen, is_utf8); + } else { 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; @@ -408,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; @@ -417,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) @@ -429,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])) { @@ -445,7 +464,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, | return_svp, NULL /* no value */, 0 /* compute hash */); - if (!entry && (action & HV_FETCH_LVALUE)) { + if (!result && (action & HV_FETCH_LVALUE)) { /* This call will free key if necessary. Do it this way to encourage compiler to tail call optimise. */ @@ -464,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(); @@ -472,14 +492,13 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (keysv || is_utf8) { if (!keysv) { - keysv = newSVpvn(key, klen); - SvUTF8_on(keysv); + keysv = newSVpvn_utf8(key, klen, TRUE); } 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); @@ -490,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. */ @@ -515,15 +534,14 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, const bool save_taint = PL_tainted; if (keysv || is_utf8) { if (!keysv) { - keysv = newSVpvn(key, klen); - SvUTF8_on(keysv); + keysv = newSVpvn_utf8(key, klen, TRUE); } 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); @@ -533,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. */ @@ -556,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; @@ -580,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) @@ -591,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; } } @@ -699,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) { @@ -819,6 +844,9 @@ STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) { const MAGIC *mg = SvMAGIC(hv); + + PERL_ARGS_ASSERT_HV_MAGIC_CHECK; + *needs_copy = FALSE; *needs_store = TRUE; while (mg) { @@ -846,14 +874,16 @@ Perl_hv_scalar(pTHX_ HV *hv) { SV *sv; + 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 @@ -917,9 +947,9 @@ 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 = sv_2mortal(newSVpvn(key,klen)); + keysv = newSVpvn_flags(key, klen, SVs_TEMP); if (k_flags & HVhek_FREEKEY) { Safefree(key); } @@ -952,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)) { @@ -1059,6 +1089,8 @@ S_hsplit(pTHX_ HV *hv) int longest_chain = 0; int was_shared; + PERL_ARGS_ASSERT_HSPLIT; + /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", (void*)hv, (int) oldsize);*/ @@ -1079,7 +1111,7 @@ S_hsplit(pTHX_ HV *hv) return; } if (SvOOK(hv)) { - Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); + Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } #else Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) @@ -1228,6 +1260,8 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) register HE *entry; register HE **oentry; + PERL_ARGS_ASSERT_HV_KSPLIT; + newsize = (I32) newmax; /* possible truncation here */ if (newsize != newmax || newmax <= oldsize) return; @@ -1305,30 +1339,6 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) } } -/* -=for apidoc newHV - -Creates a new HV. The reference count is set to 1. - -=cut -*/ - -HV * -Perl_newHV(pTHX) -{ - register XPVHV* xhv; - HV * const hv = (HV*)newSV_type(SVt_PVHV); - xhv = (XPVHV*)SvANY(hv); - assert(!SvOK(hv)); -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif - - xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */ - xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ - return hv; -} - HV * Perl_newHVhv(pTHX_ HV *ohv) { @@ -1339,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); @@ -1447,10 +1457,12 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) dVAR; SV *val; + PERL_ARGS_ASSERT_HV_FREE_ENT; + if (!entry) return; val = HeVAL(entry); - if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv)) + if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv)) mro_method_changed_in(hv); /* deletion of method from stash */ SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { @@ -1468,6 +1480,9 @@ void Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { dVAR; + + PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; + if (!entry) return; /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ @@ -1527,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); @@ -1559,6 +1574,8 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) dVAR; const U32 items = (U32)HvPLACEHOLDERS_get(hv); + PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; + if (items) clear_placeholders(hv, items); } @@ -1569,6 +1586,8 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) dVAR; I32 i; + PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; + if (items == 0) return; @@ -1616,6 +1635,8 @@ S_hfreeentries(pTHX_ HV *hv) HEK *name; int attempts = 100; + PERL_ARGS_ASSERT_HFREEENTRIES; + if (!orig_array) return; @@ -1666,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; @@ -1681,9 +1703,19 @@ 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); iter->xhv_mro_meta = NULL; } @@ -1788,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* @@ -1796,6 +1828,8 @@ S_hv_auxinit(HV *hv) { struct xpvhv_aux *iter; char *array; + PERL_ARGS_ASSERT_HV_AUXINIT; + if (!HvARRAY(hv)) { Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) + sizeof(struct xpvhv_aux), char); @@ -1835,6 +1869,10 @@ value, you can get it through the macro C. I32 Perl_hv_iterinit(pTHX_ HV *hv) { + PERL_ARGS_ASSERT_HV_ITERINIT; + + /* FIXME: Are we not NULL, or do we croak? Place bets now! */ + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -1859,6 +1897,8 @@ I32 * Perl_hv_riter_p(pTHX_ HV *hv) { struct xpvhv_aux *iter; + PERL_ARGS_ASSERT_HV_RITER_P; + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -1870,6 +1910,8 @@ HE ** Perl_hv_eiter_p(pTHX_ HV *hv) { struct xpvhv_aux *iter; + PERL_ARGS_ASSERT_HV_EITER_P; + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -1881,6 +1923,8 @@ void Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { struct xpvhv_aux *iter; + PERL_ARGS_ASSERT_HV_RITER_SET; + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -1899,6 +1943,8 @@ void Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { struct xpvhv_aux *iter; + PERL_ARGS_ASSERT_HV_EITER_SET; + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -1922,6 +1968,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) struct xpvhv_aux *iter; U32 hash; + PERL_ARGS_ASSERT_HV_NAME_SET; PERL_UNUSED_ARG(flags); if (len > I32_MAX) @@ -1945,7 +1992,10 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) AV ** Perl_hv_backreferences_p(pTHX_ HV *hv) { struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); + + PERL_ARGS_ASSERT_HV_BACKREFERENCES_P; PERL_UNUSED_CONTEXT; + return &(iter->xhv_backreferences); } @@ -1953,6 +2003,8 @@ void Perl_hv_kill_backrefs(pTHX_ HV *hv) { AV *av; + PERL_ARGS_ASSERT_HV_KILL_BACKREFS; + if (!SvOOK(hv)) return; @@ -1960,7 +2012,8 @@ 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); } } @@ -2003,6 +2056,8 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) MAGIC* mg; struct xpvhv_aux *iter; + PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS; + if (!hv) Perl_croak(aTHX_ "Bad hash"); @@ -2018,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)); @@ -2031,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)); @@ -2051,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 @@ -2127,6 +2183,8 @@ C. char * Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) { + PERL_ARGS_ASSERT_HV_ITERKEY; + if (HeKLEN(entry) == HEf_SVKEY) { STRLEN len; char * const p = SvPV(HeKEY_sv(entry), len); @@ -2153,6 +2211,8 @@ see C. SV * Perl_hv_iterkeysv(pTHX_ register HE *entry) { + PERL_ARGS_ASSERT_HV_ITERKEYSV; + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } @@ -2168,13 +2228,15 @@ C. SV * 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; } } @@ -2195,6 +2257,8 @@ Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) { HE * const he = hv_iternext_flags(hv, 0); + PERL_ARGS_ASSERT_HV_ITERNEXTSV; + if (!he) return NULL; *key = hv_iterkey(he, retlen); @@ -2341,6 +2405,8 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) int flags = 0; const char * const save = str; + PERL_ARGS_ASSERT_SHARE_HEK; + if (len < 0) { STRLEN tmplen = -len; is_utf8 = TRUE; @@ -2368,6 +2434,9 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) register HE *entry; const int flags_masked = flags & HVhek_MASK; const U32 hindex = hash & (I32) HvMAX(PL_strtab); + register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); + + PERL_ARGS_ASSERT_SHARE_HEK_FLAGS; /* what follows is the moral equivalent of: @@ -2377,7 +2446,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) Can't rehash the shared string table, so not sure if it's worth counting the number of entries in the linked list */ - register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); + /* assert(xhv_array != 0) */ LOCK_STRTAB_MUTEX; entry = (HvARRAY(PL_strtab))[hindex]; @@ -2449,10 +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"); @@ -2463,10 +2534,12 @@ Perl_hv_placeholders_p(pTHX_ HV *hv) I32 -Perl_hv_placeholders_get(pTHX_ HV *hv) +Perl_hv_placeholders_get(pTHX_ const HV *hv) { 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_GET; return mg ? mg->mg_len : 0; } @@ -2475,12 +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. */ @@ -2491,6 +2566,9 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he) { dVAR; SV *value; + + PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE; + switch(he->refcounted_he_data[0] & HVrhek_typemask) { case HVrhek_undef: value = newSV(0); @@ -2638,49 +2716,53 @@ Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, /* 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 (chain) { + /* No point in doing any of this if there's nothing to find. */ + bool is_utf8; - if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvSHARED_HASH(keysv); - } else { - PERL_HASH(hash, key, klen); - } - } + 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) { + 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; + 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; + 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; + value = sv_2mortal(refcounted_he_value(chain)); + break; + } } if (flags & HVhek_FREEKEY) @@ -2703,21 +2785,18 @@ 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; bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; if (SvPOK(value)) { value_type = HVrhek_PV; } else if (SvIOK(value)) { - value_type = 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)) { @@ -2727,12 +2806,41 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, } if (value_type == HVrhek_PV) { + /* Do it this way so that the SvUTF8() test is after the SvPV, in case + the value is overloaded, and doesn't yet have the UTF-8flag set. */ value_p = SvPV_const(value, value_len); - key_offset = value_len + 2; - } else { - value_len = 0; - key_offset = 1; + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; } + flags = value_type; + + 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; + } + + return refcounted_he_new_common(parent, key_p, key_len, flags, value_type, + ((value_type == HVrhek_PV + || value_type == HVrhek_PV_UTF8) ? + (void *)value_p : (void *)value), + value_len); +} + +static struct refcounted_he * +S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, + const char *const key_p, const STRLEN key_len, + const char flags, char value_type, + const void *value, const STRLEN value_len) { + dVAR; + struct refcounted_he *he; + U32 hash; + const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8; + STRLEN key_offset = is_pv ? value_len + 2 : 1; + + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON; #ifdef USE_ITHREADS he = (struct refcounted_he*) @@ -2745,33 +2853,17 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, + key_offset); #endif - he->refcounted_he_next = parent; - if (value_type == HVrhek_PV) { - Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + if (is_pv) { + Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char); he->refcounted_he_val.refcounted_he_u_len = value_len; - /* Do it this way so that the SvUTF8() test is after the SvPV, in case - the value is overloaded, and doesn't yet have the UTF-8flag set. */ - if (SvUTF8(value)) - value_type = HVrhek_PV_UTF8; } else if (value_type == HVrhek_IV) { - if (SvUOK(value)) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); - value_type = HVrhek_UV; - } else { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX(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((const SV *)value); } - flags = value_type; - 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 @@ -2830,6 +2922,49 @@ Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { } } +const char * +Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, + U32 *flags) { + if (!chain) + return NULL; +#ifdef USE_ITHREADS + if (chain->refcounted_he_keylen != 1) + return NULL; + if (*REF_HE_KEY(chain) != ':') + return NULL; +#else + if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1) + return NULL; + if (*HEK_KEY(chain->refcounted_he_hek) != ':') + return NULL; +#endif + /* Stop anyone trying to really mess us up by adding their own value for + ':' into %^H */ + if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV + && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) + return NULL; + + if (len) + *len = chain->refcounted_he_val.refcounted_he_u_len; + if (flags) { + *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) + == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; + } + return chain->refcounted_he_data + 1; +} + +/* As newSTATEOP currently gets passed plain char* labels, we will only provide + that interface. Once it works out how to pass in length and UTF-8 ness, this + function will need superseding. */ +struct refcounted_he * +Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) +{ + PERL_ARGS_ASSERT_STORE_COP_LABEL; + + return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV, + label, strlen(label)); +} + /* =for apidoc hv_assert @@ -2852,6 +2987,8 @@ Perl_hv_assert(pTHX_ HV *hv) const I32 riter = HvRITER_get(hv); HE *eiter = HvEITER_get(hv); + PERL_ARGS_ASSERT_HV_ASSERT; + (void)hv_iterinit(hv); while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { @@ -2874,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); @@ -2895,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);