X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fda2d18a806c2883a36b25ff9f691418a05ccea0..8ae5a962c7aabc579338e8a0f74ead4acb914e83:/hv.c diff --git a/hv.c b/hv.c index a9f4aa4..da8d764 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"] */ /* @@ -36,21 +40,6 @@ holds the key and hash value. static const char S_strtab_error[] = "Cannot modify shared string table in hv_%s"; -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]; - - PL_body_roots[HE_SVSLOT] = he; - while (he < heend) { - HeNEXT(he) = (HE*)(he + 1); - he++; - } - HeNEXT(he) = 0; -} - #ifdef PURIFY #define new_HE() (HE*)safemalloc(sizeof(HE)) @@ -66,7 +55,7 @@ S_new_he(pTHX) void ** const root = &PL_body_roots[HE_SVSLOT]; if (!*root) - S_more_he(aTHX); + Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE); he = (HE*) *root; assert(he); *root = HeNEXT(he); @@ -91,6 +80,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); @@ -125,10 +116,15 @@ Perl_free_tied_hv_pool(pTHX) HEK * Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) { - HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + HEK *shared; + PERL_ARGS_ASSERT_HEK_DUP; PERL_UNUSED_ARG(param); + if (!source) + return NULL; + + shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); if (shared) { /* We already shared this hash key. */ (void)share_hek_hek(shared); @@ -147,6 +143,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,9 +159,9 @@ 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)); + HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param); } else if (shared) { /* This is hek_dup inlined, which seems to be important for speed @@ -186,7 +184,7 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) else HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); - HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param)); + HeVAL(ret) = sv_dup_inc(HeVAL(e), param); return ret; } #endif /* USE_ITHREADS */ @@ -196,6 +194,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); } @@ -236,39 +237,6 @@ hv_store_ent. See L for more information on how to use this function on tied hashes. -=cut -*/ - -SV** -Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) -{ - HE *hek; - STRLEN klen; - int flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; - } else { - klen = klen_i32; - flags = 0; - } - hek = hv_fetch_common (hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); - return hek ? &HeVAL(hek) : NULL; -} - -/* XXX This looks like an ideal candidate to inline */ -SV** -Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, - register U32 hash, int flags) -{ - HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); - return hek ? &HeVAL(hek) : NULL; -} - -/* =for apidoc hv_store_ent Stores C in a hash. The hash key is specified as C. The C @@ -294,43 +262,11 @@ hv_store in preference to hv_store_ent. See L for more information on how to use this function on tied hashes. -=cut -*/ - -/* XXX This looks like an ideal candidate to inline */ -HE * -Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) -{ - return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash); -} - -/* =for apidoc hv_exists Returns a boolean indicating whether the specified hash key exists. The C is the length of the key. -=cut -*/ - -bool -Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) -{ - STRLEN klen; - int flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; - } else { - klen = klen_i32; - flags = 0; - } - return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) - ? TRUE : FALSE; -} - -/* =for apidoc hv_fetch Returns the SV which corresponds to the specified key in the hash. The @@ -341,30 +277,6 @@ dereferencing it to an C. See L for more information on how to use this function on tied hashes. -=cut -*/ - -SV** -Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) -{ - HE *hek; - STRLEN klen; - int flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; - } else { - klen = klen_i32; - flags = 0; - } - hek = hv_fetch_common (hv, NULL, key, klen, flags, - lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) : HV_FETCH_JUST_SV, - NULL, 0); - return hek ? &HeVAL(hek) : NULL; -} - -/* =for apidoc hv_exists_ent Returns a boolean indicating whether the specified hash key exists. C @@ -374,14 +286,6 @@ computed. =cut */ -/* XXX This looks like an ideal candidate to inline */ -bool -Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) -{ - return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) - ? TRUE : FALSE; -} - /* returns an HE * structure with the all fields set */ /* note that hent_val will be a mortal sv for MAGICAL hashes */ /* @@ -391,7 +295,7 @@ Returns the hash entry which corresponds to the specified key in the hash. C must be a valid precomputed hash number for the given C, or 0 if you want the function to compute it. IF C is set then the fetch will be part of a store. Make sure the return value is non-null before -accessing it. The return value when C is a tied hash is a pointer to a +accessing it. The return value when C is a tied hash is a pointer to a static location, so be sure to make a copy of the structure if you need to store it somewhere. @@ -401,16 +305,29 @@ information on how to use this function on tied hashes. =cut */ -HE * -Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) +/* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */ +void * +Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, + const int action, SV *val, const U32 hash) { - return hv_fetch_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), NULL, hash); + STRLEN klen; + int flags; + + PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + return hv_common(hv, NULL, key, klen, flags, action, val, hash); } -STATIC HE * -S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, - int flags, int action, SV *val, register U32 hash) +void * +Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, + int flags, int action, SV *val, register U32 hash) { dVAR; XPVHV* xhv; @@ -419,26 +336,31 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, SV *sv; bool is_utf8; int masked_flags; + const int return_svp = action & HV_FETCH_JUST_SV; if (!hv) return NULL; + if (SvTYPE(hv) == SVTYPEMASK) + return NULL; + + assert(SvTYPE(hv) == SVt_PVHV); 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; @@ -452,35 +374,37 @@ S_hv_fetch_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); } if (action & HV_DELETE) { - return (HE *) hv_delete_common(hv, keysv, key, klen, - flags | (is_utf8 ? HVhek_UTF8 : 0), - action, hash); + return (void *) hv_delete_common(hv, keysv, key, klen, + flags | (is_utf8 ? HVhek_UTF8 : 0), + action, hash); } 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)) { - /* XXX should be able to skimp on the HE/HEK here when + /* 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; @@ -489,7 +413,7 @@ S_hv_fetch_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; @@ -498,16 +422,19 @@ S_hv_fetch_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) Safefree(key); - return entry; + if (return_svp) { + return entry ? (void *) &HeVAL(entry) : NULL; + } + 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])) { @@ -516,32 +443,34 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, const char * const nkey = strupr(savepvn(key,klen)); /* Note that this fetch is for nkey (the uppercased key) whereas the store is for key (the original) */ - entry = hv_fetch_common(hv, NULL, nkey, klen, - HVhek_FREEKEY, /* free nkey */ - 0 /* non-LVAL fetch */ - | HV_DISABLE_UVAR_XKEY, - NULL /* no value */, - 0 /* compute hash */); - if (!entry && (action & HV_FETCH_LVALUE)) { + void *result = hv_common(hv, NULL, nkey, klen, + HVhek_FREEKEY, /* free nkey */ + 0 /* non-LVAL fetch */ + | HV_DISABLE_UVAR_XKEY + | return_svp, + NULL /* no value */, + 0 /* compute hash */); + if (!result && (action & HV_FETCH_LVALUE)) { /* This call will free key if necessary. Do it this way to encourage compiler to tail call optimise. */ - entry = hv_fetch_common(hv, keysv, key, klen, - flags, - HV_FETCH_ISSTORE - | HV_DISABLE_UVAR_XKEY, - newSV(0), hash); + result = hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE + | HV_DISABLE_UVAR_XKEY + | return_svp, + newSV(0), hash); } else { if (flags & HVhek_FREEKEY) Safefree(key); } - return entry; + return result; } } #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(); @@ -549,14 +478,13 @@ S_hv_fetch_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); @@ -564,10 +492,10 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* This cast somewhat evil, but I'm merely using NULL/ not NULL to return the boolean exists. And I know hv is not NULL. */ - return SvTRUE(svret) ? (HE *)hv : NULL; + 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. */ @@ -592,15 +520,14 @@ S_hv_fetch_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); @@ -610,7 +537,7 @@ S_hv_fetch_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. */ @@ -633,7 +560,8 @@ S_hv_fetch_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; @@ -653,11 +581,11 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (flags & HVhek_FREEKEY) Safefree(key); - return 0; + return NULL; } } - 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) @@ -668,6 +596,11 @@ S_hv_fetch_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; } } @@ -769,19 +702,23 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } if (flags & HVhek_FREEKEY) Safefree(key); + if (return_svp) { + return entry ? (void *) &HeVAL(entry) : NULL; + } return entry; } #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) { sv = newSVpvn(env,len); SvTAINTED_on(sv); - return hv_fetch_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv, - hash); + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + sv, hash); } } #endif @@ -795,7 +732,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Not doing some form of store, so return failure. */ if (flags & HVhek_FREEKEY) Safefree(key); - return 0; + return NULL; } if (action & HV_FETCH_LVALUE) { val = newSV(0); @@ -810,9 +747,9 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, However, as we replace the original key with the converted key, this would result in a double conversion, which would show up as a bug if the conversion routine is not idempotent. */ - return hv_fetch_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val, - hash); + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + val, hash); /* XXX Surely that could leak if the fetch-was-store fails? Just like the hv_fetch. */ } @@ -862,8 +799,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!counter) { /* initial entry? */ - xhv->xhv_fill++; /* HvFILL(hv)++ */ - } else if (xhv->xhv_keys > (IV)xhv->xhv_max) { + } else if (xhv->xhv_keys > xhv->xhv_max) { hsplit(hv); } else if(!HvREHASH(hv)) { U32 n_links = 1; @@ -883,13 +819,19 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } - return entry; + if (return_svp) { + return entry ? (void *) &HeVAL(entry) : NULL; + } + return (void *) entry; } 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) { @@ -917,14 +859,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 (HvTOTALKEYS((const HV *)hv)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); else @@ -936,50 +880,22 @@ Perl_hv_scalar(pTHX_ HV *hv) /* =for apidoc hv_delete -Deletes a key/value pair in the hash. The value SV is removed from the -hash and returned to the caller. The C is the length of the key. -The C value will normally be zero; if set to G_DISCARD then NULL -will be returned. - -=cut -*/ - -SV * -Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) -{ - STRLEN klen; - int k_flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - k_flags = HVhek_UTF8; - } else { - klen = klen_i32; - k_flags = 0; - } - return (SV *) hv_fetch_common(hv, NULL, key, klen, k_flags, - flags | HV_DELETE, NULL, 0); -} +Deletes a key/value pair in the hash. The value's SV is removed from the +hash, made mortal, and returned to the caller. The C is the length of +the key. The C value will normally be zero; if set to G_DISCARD then +NULL will be returned. NULL will also be returned if the key is not found. -/* =for apidoc hv_delete_ent -Deletes a key/value pair in the hash. The value SV is removed from the -hash and returned to the caller. The C value will normally be zero; -if set to G_DISCARD then NULL will be returned. C can be a valid -precomputed hash value, or 0 to ask for it to be computed. +Deletes a key/value pair in the hash. The value SV is removed from the hash, +made mortal, and returned to the caller. The C value will normally be +zero; if set to G_DISCARD then NULL will be returned. NULL will also be +returned if the key is not found. C can be a valid precomputed hash +value, or 0 to ask for it to be computed. =cut */ -/* XXX This looks like an ideal candidate to inline */ -SV * -Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) -{ - return (SV *) hv_fetch_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, - NULL, hash); -} - STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash) @@ -999,10 +915,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (needs_copy) { SV *sv; - entry = hv_fetch_common(hv, keysv, key, klen, - k_flags & ~HVhek_FREEKEY, - HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, - NULL, hash); + entry = (HE *) hv_common(hv, keysv, key, klen, + k_flags & ~HVhek_FREEKEY, + HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, + NULL, hash); sv = entry ? HeVAL(entry) : NULL; if (sv) { if (SvMAGICAL(sv)) { @@ -1017,9 +933,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); } @@ -1052,7 +968,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)) { @@ -1071,6 +987,11 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, entry = *oentry; for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { SV *sv; + bool mpm = FALSE; + const char *name = NULL; + STRLEN namlen; + HV *stash = NULL; + if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) @@ -1100,6 +1021,40 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (k_flags & HVhek_FREEKEY) Safefree(key); + /* 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); + if (keysv) key = SvPV(keysv, klen); + if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':' + && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) + && SvTYPE(sv) == SVt_PVGV && (stash = GvHV((GV *)sv)) + && 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 + ) { + mpm = TRUE; + 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) + ); + } + } + } + if (d_flags & G_DISCARD) sv = NULL; else { @@ -1121,9 +1076,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HvPLACEHOLDERS(hv)++; } else { *oentry = HeNEXT(entry); - if(!*first_entry) { - xhv->xhv_fill--; /* HvFILL(hv)-- */ - } if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) HvLAZYDEL_on(hv); else @@ -1132,6 +1084,9 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (xhv->xhv_keys == 0) HvHASKFLAGS_off(hv); } + + if (mpm) mro_package_moved(NULL, stash, NULL, name, namlen); + return sv; } if (SvREADONLY(hv)) { @@ -1155,10 +1110,11 @@ S_hsplit(pTHX_ HV *hv) register I32 i; char *a = (char*) HvARRAY(hv); register HE **aep; - register HE **oentry; 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);*/ @@ -1179,7 +1135,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) @@ -1192,13 +1148,7 @@ S_hsplit(pTHX_ HV *hv) if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } - if (oldsize >= 64) { - offer_nice_chunk(HvARRAY(hv), - PERL_HV_ARRAY_ALLOC_BYTES(oldsize) - + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); - } - else - Safefree(HvARRAY(hv)); + Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; @@ -1210,29 +1160,26 @@ S_hsplit(pTHX_ HV *hv) for (i=0; ixhv_fill++; /* HvFILL(hv)++ */ *bep = entry; right_length++; - continue; } else { oentry = &HeNEXT(entry); left_length++; } - } - if (!*aep) /* everything moved */ - xhv->xhv_fill--; /* HvFILL(hv)-- */ + entry = *oentry; + } while (entry); /* I think we don't actually need to keep track of the longest length, merely flag if anything is too long. But for the moment while developing this code I'll track it. */ @@ -1268,7 +1215,6 @@ S_hsplit(pTHX_ HV *hv) was_shared = HvSHAREKEYS(hv); - xhv->xhv_fill = 0; HvSHAREKEYS_off(hv); HvREHASH_on(hv); @@ -1303,8 +1249,6 @@ S_hsplit(pTHX_ HV *hv) /* Copy oentry to the correct new chain. */ bep = ((HE**)a) + (hash & (I32) xhv->xhv_max); - if (!*bep) - xhv->xhv_fill++; /* HvFILL(hv)++ */ HeNEXT(entry) = *bep; *bep = entry; @@ -1325,8 +1269,8 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) register I32 i; register char *a; register HE **aep; - register HE *entry; - register HE **oentry; + + PERL_ARGS_ASSERT_HV_KSPLIT; newsize = (I32) newmax; /* possible truncation here */ if (newsize != newmax || newmax <= oldsize) @@ -1363,13 +1307,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) if (SvOOK(hv)) { Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); } - if (oldsize >= 64) { - offer_nice_chunk(HvARRAY(hv), - PERL_HV_ARRAY_ALLOC_BYTES(oldsize) - + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); - } - else - Safefree(HvARRAY(hv)); + Safefree(HvARRAY(hv)); #endif PL_nomemok = FALSE; Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ @@ -1379,67 +1317,44 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) } xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ HvARRAY(hv) = (HE **) a; - if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ + if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */) /* skip rest if no entries */ return; aep = (HE**)a; for (i=0; ixhv_fill++; /* HvFILL(hv)++ */ + HeNEXT(entry) = aep[j]; aep[j] = entry; - continue; } else oentry = &HeNEXT(entry); - } - if (!*aep) /* everything moved */ - xhv->xhv_fill--; /* HvFILL(hv)-- */ + entry = *oentry; + } while (entry); } } -/* -=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) { + dVAR; HV * const hv = newHV(); - STRLEN hv_max, hv_fill; + STRLEN hv_max; - if (!ohv || (hv_fill = HvFILL(ohv)) == 0) + if (!ohv || !HvTOTALKEYS(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); @@ -1465,8 +1380,9 @@ Perl_newHVhv(pTHX_ HV *ohv) const STRLEN len = HeKLEN(oent); const int flags = HeKFLAGS(oent); HE * const ent = new_HE(); + SV *const val = HeVAL(oent); - HeVAL(ent) = newSVsv(HeVAL(oent)); + HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) : save_hek_flags(key, len, hash, flags); @@ -1480,7 +1396,6 @@ Perl_newHVhv(pTHX_ HV *ohv) } HvMAX(hv) = hv_max; - HvFILL(hv) = hv_fill; HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); HvARRAY(hv) = ents; } /* not magical */ @@ -1489,6 +1404,7 @@ Perl_newHVhv(pTHX_ HV *ohv) HE *entry; const I32 riter = HvRITER_get(ohv); HE * const eiter = HvEITER_get(ohv); + STRLEN hv_fill = HvFILL(ohv); /* Can we use fewer buckets? (hv_max is always 2^n-1) */ while (hv_max && hv_max + 1 >= hv_fill * 2) @@ -1497,9 +1413,10 @@ Perl_newHVhv(pTHX_ HV *ohv) hv_iterinit(ohv); while ((entry = hv_iternext_flags(ohv, 0))) { - hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), - newSVsv(HeVAL(entry)), HeHASH(entry), - HeKFLAGS(entry)); + SV *const val = HeVAL(entry); + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), + SvIMMORTAL(val) ? val : newSVsv(val), + HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); @@ -1508,16 +1425,26 @@ Perl_newHVhv(pTHX_ HV *ohv) return hv; } -/* A rather specialised version of newHVhv for copying %^H, ensuring all the - magic stays on it. */ +/* +=for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv + +A specialised version of L for copying C<%^H>. I must be +a pointer to a hash (which may have C<%^H> magic, but should be generally +non-magical), or C (interpreted as an empty hash). The content +of I is copied to a new hash, which has the C<%^H>-specific magic +added to it. A pointer to the new hash is returned. + +=cut +*/ + HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) { HV * const hv = newHV(); - STRLEN hv_fill; - if (ohv && (hv_fill = HvFILL(ohv))) { + if (ohv && HvTOTALKEYS(ohv)) { STRLEN hv_max = HvMAX(ohv); + STRLEN hv_fill = HvFILL(ohv); HE *entry; const I32 riter = HvRITER_get(ohv); HE * const eiter = HvEITER_get(ohv); @@ -1529,10 +1456,12 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) hv_iterinit(ohv); while ((entry = hv_iternext_flags(ohv, 0))) { SV *const sv = newSVsv(HeVAL(entry)); + SV *heksv = newSVhek(HeKEY_hek(entry)); sv_magic(sv, NULL, PERL_MAGIC_hintselem, - (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY); - hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), - sv, HeHASH(entry), HeKFLAGS(entry)); + (char *)heksv, HEf_SVKEY); + SvREFCNT_dec(heksv); + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), + sv, HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); @@ -1547,10 +1476,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) && HvENAME(hv)) mro_method_changed_in(hv); /* deletion of method from stash */ SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { @@ -1564,10 +1495,14 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) del_HE(entry); } + 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 */ @@ -1627,13 +1562,13 @@ 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); reset: if (SvOOK(hv)) { - if(HvNAME_get(hv)) + if(HvENAME_get(hv)) mro_isa_changed_in(hv); HvEITER_set(hv, NULL); } @@ -1659,6 +1594,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); } @@ -1669,6 +1606,8 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) dVAR; I32 i; + PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; + if (items == 0) return; @@ -1682,8 +1621,6 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) while ((entry = *oentry)) { if (HeVAL(entry) == &PL_sv_placeholder) { *oentry = HeNEXT(entry); - if (first && !*oentry) - HvFILL(hv)--; /* This linked list is now empty. */ if (entry == HvEITER_get(hv)) HvLAZYDEL_on(hv); else @@ -1714,8 +1651,11 @@ S_hfreeentries(pTHX_ HV *hv) /* This is the array that we're going to restore */ HE **const orig_array = HvARRAY(hv); HEK *name; + I32 name_count; int attempts = 100; + PERL_ARGS_ASSERT_HFREEENTRIES; + if (!orig_array) return; @@ -1725,9 +1665,11 @@ S_hfreeentries(pTHX_ HV *hv) struct xpvhv_aux *iter = HvAUX(hv); name = iter->xhv_name; + name_count = iter->xhv_name_count; iter->xhv_name = NULL; } else { name = NULL; + name_count = 0; } /* orig_array remains unchanged throughout the loop. If after freeing all @@ -1750,24 +1692,43 @@ S_hfreeentries(pTHX_ HV *hv) HE *entry; struct mro_meta *meta; struct xpvhv_aux *iter = HvAUX(hv); - /* If there are weak references to this HV, we need to avoid - freeing them up here. In particular we need to keep the AV - visible as what we're deleting might well have weak references - back to this HV, so the for loop below may well trigger - the removal of backreferences from this array. */ + /* 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) { - /* So donate them to regular backref magic to keep them safe. - 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. */ + 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((SV*)hv, (SV*)iter->xhv_backreferences, - PERL_MAGIC_backref, NULL, 0); + } 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; } @@ -1781,9 +1742,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; } @@ -1795,9 +1766,8 @@ S_hfreeentries(pTHX_ HV *hv) } /* make everyone else think the array is empty, so that the destructors - * called for freed entries can't recusively mess with us */ + * called for freed entries can't recursively mess with us */ HvARRAY(hv) = NULL; - HvFILL(hv) = 0; ((XPVHV*) SvANY(hv))->xhv_keys = 0; @@ -1831,7 +1801,15 @@ S_hfreeentries(pTHX_ HV *hv) assert(HvARRAY(hv)); if (HvAUX(hv)->xhv_name) { - unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); + if(HvAUX(hv)->xhv_name_count) { + HEK ** const name = (HEK **)HvAUX(hv)->xhv_name; + I32 const count = HvAUX(hv)->xhv_name_count; + HEK **hekp = name + (count < 0 ? -count : count); + while(hekp-- > name) + unshare_hek_or_pvn(*hekp, 0, 0, 0); + Safefree(name); + } + else unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); } } @@ -1847,8 +1825,10 @@ S_hfreeentries(pTHX_ HV *hv) /* We have restored the original array. If name is non-NULL, then the original array had an aux structure at the end. So this is valid: */ + struct xpvhv_aux * const aux = HvAUX(hv); SvFLAGS(hv) |= SVf_OOK; - HvAUX(hv)->xhv_name = name; + aux->xhv_name = name; + aux->xhv_name_count = name_count; } } @@ -1872,13 +1852,13 @@ Perl_hv_undef(pTHX_ HV *hv) DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); - if ((name = HvNAME_get(hv)) && !PL_dirty) + if ((name = HvENAME_get(hv)) && !PL_dirty) mro_isa_changed_in(hv); hfreeentries(hv); - if (name) { - if(PL_stashcache) - hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); + if (name || (name = HvNAME(hv))) { + if (PL_stashcache) + (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); hv_name_set(hv, NULL, 0, 0); } SvFLAGS(hv) &= ~SVf_OOK; @@ -1888,7 +1868,39 @@ Perl_hv_undef(pTHX_ HV *hv) HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) - mg_clear((SV*)hv); + mg_clear(MUTABLE_SV(hv)); +} + +/* +=for apidoc hv_fill + +Returns the number of hash buckets that happen to be in use. This function is +wrapped by the macro C. + +Previously this value was stored in the HV structure, rather than being +calculated on demand. + +=cut +*/ + +STRLEN +Perl_hv_fill(pTHX_ HV const *const hv) +{ + STRLEN count = 0; + HE **ents = HvARRAY(hv); + + PERL_ARGS_ASSERT_HV_FILL; + + if (ents) { + HE *const *const last = ents + HvMAX(hv); + count = last + 1 - ents; + + do { + if (!*ents) + --count; + } while (++ents <= last); + } + return count; } static struct xpvhv_aux* @@ -1896,6 +1908,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); @@ -1912,6 +1926,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_count = 0; iter->xhv_backreferences = 0; iter->xhv_mro_meta = NULL; return iter; @@ -1921,12 +1936,12 @@ 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 hash buckets that happen to be in use. If you still need that esoteric -value, you can get it through the macro C. +value, you can get it through the macro C. =cut @@ -1935,6 +1950,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"); @@ -1959,6 +1978,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"); @@ -1970,6 +1991,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"); @@ -1981,6 +2004,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"); @@ -1999,6 +2024,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"); @@ -2021,7 +2048,9 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) dVAR; struct xpvhv_aux *iter; U32 hash; + HEK **spot; + PERL_ARGS_ASSERT_HV_NAME_SET; PERL_UNUSED_ARG(flags); if (len > I32_MAX) @@ -2030,22 +2059,189 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) if (SvOOK(hv)) { iter = HvAUX(hv); if (iter->xhv_name) { - unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); + if(iter->xhv_name_count) { + if(!name) { + HEK ** const name = (HEK **)HvAUX(hv)->xhv_name; + HEK **hekp = name + ( + iter->xhv_name_count < 0 + ? -iter->xhv_name_count + : iter->xhv_name_count + ); + while(hekp-- > name+1) + unshare_hek_or_pvn(*hekp, 0, 0, 0); + /* The first elem may be null. */ + if(*name) unshare_hek_or_pvn(*name, 0, 0, 0); + Safefree(name); + spot = &iter->xhv_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]; + spot[1] = spot[0]; + } + else if(*spot) { + unshare_hek_or_pvn(*spot, 0, 0, 0); + } + } + } + else { + unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); + spot = &iter->xhv_name; + } } + else spot = &iter->xhv_name; } else { if (name == 0) return; iter = hv_auxinit(hv); + spot = &iter->xhv_name; } PERL_HASH(hash, name, len); - iter->xhv_name = name ? share_hek(name, len, hash) : NULL; + *spot = name ? share_hek(name, len, hash) : NULL; + iter->xhv_name_count = 0; +} + +/* +=for apidoc hv_ename_add + +Adds a name to a stash's internal list of effective names. See +C. + +This is called when a stash is assigned to a new location in the symbol +table. + +=cut +*/ + +void +Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len) +{ + dVAR; + struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); + U32 hash; + + PERL_ARGS_ASSERT_HV_ENAME_ADD; + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + + PERL_HASH(hash, name, len); + + if (aux->xhv_name_count) { + HEK ** const xhv_name = (HEK **)aux->xhv_name; + I32 count = aux->xhv_name_count; + HEK **hekp = xhv_name + (count < 0 ? -count : count); + while (hekp-- > xhv_name) + if ( + HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len) + ) { + if (hekp == xhv_name && count < 0) + aux->xhv_name_count = -count; + return; + } + 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); + } + else { + HEK *existing_name = aux->xhv_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); + aux->xhv_name_count = existing_name ? 2 : -2; + *(HEK **)aux->xhv_name = existing_name; + ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash); + } +} + +/* +=for apidoc hv_ename_delete + +Removes a name from a stash's internal list of effective names. If this is +the name returned by C, then another name in the list will take +its place (C will use it). + +This is called when a stash is deleted from the symbol table. + +=cut +*/ + +void +Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len) +{ + dVAR; + struct xpvhv_aux *aux; + + PERL_ARGS_ASSERT_HV_ENAME_DELETE; + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + + if (!SvOOK(hv)) return; + + aux = HvAUX(hv); + if (!aux->xhv_name) return; + + if (aux->xhv_name_count) { + HEK ** const namep = (HEK **)aux->xhv_name; + I32 const count = aux->xhv_name_count; + HEK **victim = namep + (count < 0 ? -count : count); + while (victim-- > namep + 1) + if ( + HEK_LEN(*victim) == (I32)len + && memEQ(HEK_KEY(*victim), name, len) + ) { + unshare_hek_or_pvn(*victim, 0, 0, 0); + if (count < 0) ++aux->xhv_name_count; + else --aux->xhv_name_count; + if ( + (aux->xhv_name_count == 1 || aux->xhv_name_count == -1) + && !*namep + ) { /* if there are none left */ + Safefree(namep); + aux->xhv_name = NULL; + aux->xhv_name_count = 0; + } + else { + /* Move the last one back to fill the empty slot. It + does not matter what order they are in. */ + *victim = *(namep + (count < 0 ? -count : count) - 1); + } + return; + } + if ( + count > 0 && HEK_LEN(*namep) == (I32)len + && memEQ(HEK_KEY(*namep),name,len) + ) { + aux->xhv_name_count = -count; + } + } + else if( + HEK_LEN(aux->xhv_name) == (I32)len + && memEQ(HEK_KEY(aux->xhv_name), name, len) + ) { + const HEK * const namehek = aux->xhv_name; + Newxc(aux->xhv_name, 1, HEK *, HEK); + *(const HEK **)aux->xhv_name = namehek; + aux->xhv_name_count = -1; + } } 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); } @@ -2053,6 +2249,8 @@ void Perl_hv_kill_backrefs(pTHX_ HV *hv) { AV *av; + PERL_ARGS_ASSERT_HV_KILL_BACKREFS; + if (!SvOOK(hv)) return; @@ -2060,7 +2258,9 @@ 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); + if (SvTYPE(av) == SVt_PVAV) + SvREFCNT_dec(av); } } @@ -2103,6 +2303,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"); @@ -2118,7 +2320,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)); @@ -2131,19 +2333,18 @@ 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)); return entry; /* beware, hent_val is not set */ } - if (HeVAL(entry)) - SvREFCNT_dec(HeVAL(entry)); + SvREFCNT_dec(HeVAL(entry)); Safefree(HeKEY_hek(entry)); del_HE(entry); iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ @@ -2151,7 +2352,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 @@ -2181,26 +2383,31 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) } } } - while (!entry) { - /* OK. Come to the end of the current list. Grab the next one. */ - iter->xhv_riter++; /* HvRITER(hv)++ */ - if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { - /* There is no next one. End of the hash. */ - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - break; - } - entry = (HvARRAY(hv))[iter->xhv_riter]; + /* Skip the entire loop if the hash is empty. */ + if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS) + ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { + while (!entry) { + /* OK. Come to the end of the current list. Grab the next one. */ - if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { - /* If we have an entry, but it's a placeholder, don't count it. - Try the next. */ - while (entry && HeVAL(entry) == &PL_sv_placeholder) - entry = HeNEXT(entry); + iter->xhv_riter++; /* HvRITER(hv)++ */ + if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { + /* There is no next one. End of the hash. */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + break; + } + entry = (HvARRAY(hv))[iter->xhv_riter]; + + if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { + /* If we have an entry, but it's a placeholder, don't count it. + Try the next. */ + while (entry && HeVAL(entry) == &PL_sv_placeholder) + entry = HeNEXT(entry); + } + /* Will loop again if this linked list starts NULL + (for HV_ITERNEXT_WANTPLACEHOLDERS) + or if we run through it and find only placeholders. */ } - /* Will loop again if this linked list starts NULL - (for HV_ITERNEXT_WANTPLACEHOLDERS) - or if we run through it and find only placeholders. */ } if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ @@ -2227,6 +2434,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); @@ -2253,6 +2462,8 @@ see C. SV * Perl_hv_iterkeysv(pTHX_ register HE *entry) { + PERL_ARGS_ASSERT_HV_ITERKEYSV; + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } @@ -2268,13 +2479,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; } } @@ -2295,6 +2508,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); @@ -2356,13 +2571,10 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) shared hek */ assert (he->shared_he_he.hent_hek == hek); - LOCK_STRTAB_MUTEX; if (he->shared_he_he.he_valu.hent_refcount - 1) { --he->shared_he_he.he_valu.hent_refcount; - UNLOCK_STRTAB_MUTEX; return; } - UNLOCK_STRTAB_MUTEX; hash = HEK_HASH(hek); } else if (len < 0) { @@ -2384,7 +2596,6 @@ 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) */ - LOCK_STRTAB_MUTEX; first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; if (he) { const HE *const he_he = &(he->shared_he_he); @@ -2410,22 +2621,17 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) if (entry) { if (--entry->he_valu.hent_refcount == 0) { *oentry = HeNEXT(entry); - if (!*first) { - /* There are now no entries in our slot. */ - xhv->xhv_fill--; /* HvFILL(hv)-- */ - } Safefree(entry); xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ } } - UNLOCK_STRTAB_MUTEX; - if (!entry && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-existent shared string '%s'%s" - pTHX__FORMAT, - hek ? HEK_KEY(hek) : str, - ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); + if (!entry) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free non-existent shared string '%s'%s" + pTHX__FORMAT, + hek ? HEK_KEY(hek) : str, + ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); if (k_flags & HVhek_FREEKEY) Safefree(str); } @@ -2441,6 +2647,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; @@ -2468,6 +2676,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: @@ -2477,9 +2688,8 @@ 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]; for (;entry; entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ @@ -2530,14 +2740,12 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!next) { /* initial entry? */ - xhv->xhv_fill++; /* HvFILL(hv)++ */ - } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { + } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { hsplit(PL_strtab); } } ++entry->he_valu.hent_refcount; - UNLOCK_STRTAB_MUTEX; if (flags & HVhek_FREEKEY) Safefree(str); @@ -2549,10 +2757,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"); @@ -2563,10 +2773,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; } @@ -2575,12 +2787,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. */ @@ -2591,6 +2805,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); @@ -2619,37 +2836,44 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he) SvUTF8_on(value); break; default: - Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", - he->refcounted_he_data[0]); + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf, + (UV)he->refcounted_he_data[0]); } return value; } /* -=for apidoc refcounted_he_chain_2hv +=for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags -Generates and returns a C by walking up the tree starting at the passed -in C. +Generates and returns a C representing the content of a +C chain. +I is currently unused and must be zero. =cut */ HV * -Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) +Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) { dVAR; - HV *hv = newHV(); - U32 placeholders = 0; + HV *hv; + U32 placeholders, max; + + if (flags) + Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf, + (UV)flags); + /* We could chase the chain once to get an idea of the number of keys, and call ksplit. But for now we'll make a potentially inefficient hash with only 8 entries in its array. */ - const U32 max = HvMAX(hv); - + hv = newHV(); + max = HvMAX(hv); if (!HvARRAY(hv)) { char *array; Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); HvARRAY(hv) = (HE**)array; } + placeholders = 0; while (chain) { #ifdef USE_ITHREADS U32 hash = chain->refcounted_he_hash; @@ -2704,10 +2928,6 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) /* Link it into the chain. */ HeNEXT(entry) = *oentry; - if (!HeNEXT(entry)) { - /* initial entry. */ - HvFILL(hv)++; - } *oentry = entry; HvTOTALKEYS(hv)++; @@ -2730,114 +2950,236 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) return hv; } +/* +=for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Search along a C chain for an entry with the key specified +by I and I. If I has the C +bit set, the key octets are interpreted as UTF-8, otherwise they +are interpreted as Latin-1. I is a precomputed hash of the key +string, or zero if it has not been precomputed. Returns a mortal scalar +representing the value associated with the key, or C<&PL_sv_placeholder> +if there is no value associated with the key. + +=cut +*/ + SV * -Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, - const char *key, STRLEN klen, int flags, U32 hash) +Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, + const char *keypv, STRLEN keylen, U32 hash, U32 flags) { 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); - } + U8 utf8_flag; + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN; + + if (flags & ~REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf, + (UV)flags); + if (!chain) + return &PL_sv_placeholder; + if (flags & REFCOUNTED_HE_KEY_UTF8) { + /* For searching purposes, canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + if (!((c & 0xfe) == 0xc2 && ++p != keyend && + (((U8)*p) & 0xc0) == 0x80)) + goto canonicalised_key; + nonascii_count++; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; + *q = (char) + ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c); + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } + utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0; + if (!hash) + PERL_HASH(hash, keypv, keylen); for (; chain; chain = chain->refcounted_he_next) { + if ( #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; + hash == chain->refcounted_he_hash && + keylen == chain->refcounted_he_keylen && + memEQ(REF_HE_KEY(chain), keypv, keylen) && + utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) #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; + hash == HEK_HASH(chain->refcounted_he_hek) && + keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && + memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && + utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) #endif - - value = sv_2mortal(refcounted_he_value(chain)); - break; + ) + return sv_2mortal(refcounted_he_value(chain)); } + return &PL_sv_placeholder; +} - if (flags & HVhek_FREEKEY) - Safefree(key); +/* +=for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags - return value; +Like L, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +SV * +Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, + const char *key, U32 hash, U32 flags) +{ + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV; + return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags); } /* -=for apidoc refcounted_he_new +=for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +SV * +Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain, + SV *key, U32 hash, U32 flags) +{ + const char *keypv; + STRLEN keylen; + PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV; + if (flags & REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf, + (UV)flags); + keypv = SvPV_const(key, keylen); + if (SvUTF8(key)) + flags |= REFCOUNTED_HE_KEY_UTF8; + if (!hash && SvIsCOW_shared_hash(key)) + hash = SvSHARED_HASH(key); + return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags); +} -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. +/* +=for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags + +Creates a new C. This consists of a single key/value +pair and a reference to an existing C chain (which may +be empty), and thus forms a longer chain. When using the longer chain, +the new key/value pair takes precedence over any entry for the same key +further along the chain. + +The new key is specified by I and I. If I has +the C bit set, the key octets are interpreted +as UTF-8, otherwise they are interpreted as Latin-1. I is +a precomputed hash of the key string, or zero if it has not been +precomputed. + +I is the scalar value to store for this key. I is copied +by this function, which thus does not take ownership of any reference +to it, and later changes to the scalar will not be reflected in the +value visible in the C. Complex types of scalar will not +be stored with referential integrity, but will be coerced to strings. +I may be either null or C<&PL_sv_placeholder> to indicate that no +value is to be associated with the key; this, as with any non-null value, +takes precedence over the existence of a value for the key further along +the chain. + +I points to the rest of the C chain to be +attached to the new C. This function takes ownership +of one reference to I, and returns one reference to the new +C. =cut */ struct refcounted_he * -Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, - SV *const key, SV *const value) { +Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, + const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) +{ 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; + bool is_pv; char value_type; - char flags; - STRLEN key_offset; - U32 hash; - bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; + char hekflags; + STRLEN key_offset = 1; + struct refcounted_he *he; + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN; - if (SvPOK(value)) { + if (!value || value == &PL_sv_placeholder) { + value_type = HVrhek_delete; + } else 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; + value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; } else if (!SvOK(value)) { value_type = HVrhek_undef; } else { value_type = HVrhek_PV; } - - if (value_type == HVrhek_PV) { + is_pv = value_type == HVrhek_PV; + if (is_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); + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; key_offset = value_len + 2; - } else { - value_len = 0; - key_offset = 1; } + hekflags = value_type; + + if (flags & REFCOUNTED_HE_KEY_UTF8) { + /* Canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + U8 c = (U8)*p; + if (c & 0x80) { + if (!((c & 0xfe) == 0xc2 && ++p != keyend && + (((U8)*p) & 0xc0) == 0x80)) + goto canonicalised_key; + nonascii_count++; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; + *q = (char) + ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c); + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; + } + if (flags & REFCOUNTED_HE_KEY_UTF8) + hekflags |= HVhek_UTF8; + if (!hash) + PERL_HASH(hash, keypv, keylen); #ifdef USE_ITHREADS he = (struct refcounted_he*) PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + key_len + + keylen + key_offset); #else he = (struct refcounted_he*) @@ -2845,61 +3187,83 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, + key_offset); #endif - he->refcounted_he_next = parent; - if (value_type == HVrhek_PV) { + if (is_pv) { Copy(value_p, 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(value); + } else if (value_type == HVrhek_UV) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(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 he->refcounted_he_hash = hash; - he->refcounted_he_keylen = key_len; - Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); + he->refcounted_he_keylen = keylen; + Copy(keypv, he->refcounted_he_data + key_offset, keylen, char); #else - he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); + he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags); #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_data[0] = hekflags; he->refcounted_he_refcnt = 1; return he; } /* -=for apidoc refcounted_he_free +=for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags -Decrements the reference count of the passed in C -by one. If the reference count reaches zero the structure's memory is freed, -and C iterates onto the parent node. +Like L, but takes a nul-terminated string instead +of a string/length pair. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent, + const char *key, U32 hash, SV *value, U32 flags) +{ + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV; + return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags); +} + +/* +=for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent, + SV *key, U32 hash, SV *value, U32 flags) +{ + const char *keypv; + STRLEN keylen; + PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV; + if (flags & REFCOUNTED_HE_KEY_UTF8) + Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf, + (UV)flags); + keypv = SvPV_const(key, keylen); + if (SvUTF8(key)) + flags |= REFCOUNTED_HE_KEY_UTF8; + if (!hash && SvIsCOW_shared_hash(key)) + hash = SvSHARED_HASH(key); + return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags); +} + +/* +=for apidoc m|void|refcounted_he_free|struct refcounted_he *he + +Decrements the reference count of a C by one. If the +reference count reaches zero the structure's memory is freed, which +(recursively) causes a reduction of its parent C's +reference count. It is safe to pass a null pointer to this function: +no action occurs in this case. =cut */ @@ -2931,6 +3295,80 @@ Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { } /* +=for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he + +Increment the reference count of a C. The pointer to the +C is also returned. It is safe to pass a null pointer +to this function: no action occurs and a null pointer is returned. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) +{ + if (he) { + HINTS_REFCNT_LOCK; + he->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } + return he; +} + +/* pp_entereval is aware that labels are stored with a key ':' at the top of + the linked list. */ +const char * +Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) { + struct refcounted_he *const chain = cop->cop_hints_hash; + + PERL_ARGS_ASSERT_FETCH_COP_LABEL; + + 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; +} + +void +Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len, + U32 flags) +{ + SV *labelsv; + PERL_ARGS_ASSERT_STORE_COP_LABEL; + + if (flags & ~(SVf_UTF8)) + Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf, + (UV)flags); + labelsv = sv_2mortal(newSVpvn(label, len)); + if (flags & SVf_UTF8) + SvUTF8_on(labelsv); + cop->cop_hints_hash + = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); +} + +/* =for apidoc hv_assert Check that a hash is in an internally consistent state. @@ -2952,6 +3390,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))) { @@ -2974,7 +3414,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); @@ -2995,7 +3435,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);