X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=acc58e20ffcdba63d7701683f806faeca5fc6518;hb=c568a9d1864be7bd340b9735735b6a68182a27fe;hp=f1b3c906f6ab62fcda9e62ce370ac12cc5b421a4;hpb=d3ba3f5c3251cdefafd2e9fe0bb52ce4419c7624;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index f1b3c90..acc58e2 100644 --- a/hv.c +++ b/hv.c @@ -40,8 +40,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 +94,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 +132,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 +153,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 */ @@ -196,6 +204,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 +247,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_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_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 +272,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_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_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 +287,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_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 +296,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_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 */ /* @@ -401,14 +315,27 @@ 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_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); } -HE * +void * Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int flags, int action, SV *val, register U32 hash) { @@ -419,9 +346,14 @@ Perl_hv_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; @@ -431,9 +363,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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 */ @@ -459,9 +391,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } 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); @@ -469,14 +401,11 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((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(); @@ -504,7 +433,10 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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)) { @@ -516,26 +448,27 @@ Perl_hv_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_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_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 @@ -549,8 +482,7 @@ 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); } @@ -564,7 +496,7 @@ Perl_hv_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)) { @@ -592,8 +524,7 @@ 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); @@ -653,7 +584,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (flags & HVhek_FREEKEY) Safefree(key); - return 0; + return NULL; } } @@ -769,6 +700,9 @@ Perl_hv_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 */ @@ -780,7 +714,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, sv = newSVpvn(env,len); SvTAINTED_on(sv); return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv, hash); + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + sv, hash); } } #endif @@ -794,7 +729,7 @@ Perl_hv_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,7 +745,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, key, this would result in a double conversion, which would show up as a bug if the conversion routine is not idempotent. */ return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val, hash); + 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. */ } @@ -881,13 +817,19 @@ Perl_hv_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) { @@ -915,6 +857,8 @@ 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); if (mg) @@ -939,27 +883,6 @@ 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_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE, - NULL, 0); -} - -/* =for apidoc hv_delete_ent Deletes a key/value pair in the hash. The value SV is removed from the @@ -970,14 +893,6 @@ 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_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) @@ -997,9 +912,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (needs_copy) { SV *sv; - entry = hv_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)) { @@ -1016,7 +932,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #ifdef ENV_IS_CASELESS else if (mg_find((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); } @@ -1156,6 +1072,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);*/ @@ -1325,6 +1243,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; @@ -1402,30 +1322,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) { @@ -1494,9 +1390,9 @@ 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)); + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), + newSVsv(HeVAL(entry)), HeHASH(entry), + HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); @@ -1528,8 +1424,8 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) SV *const sv = newSVsv(HeVAL(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)); + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), + sv, HeHASH(entry), HeKFLAGS(entry)); } HvRITER_set(ohv, riter); HvEITER_set(ohv, eiter); @@ -1544,10 +1440,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) { @@ -1565,6 +1463,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 */ @@ -1656,6 +1557,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); } @@ -1666,6 +1569,8 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) dVAR; I32 i; + PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; + if (items == 0) return; @@ -1713,6 +1618,8 @@ S_hfreeentries(pTHX_ HV *hv) HEK *name; int attempts = 100; + PERL_ARGS_ASSERT_HFREEENTRIES; + if (!orig_array) return; @@ -1874,8 +1781,8 @@ Perl_hv_undef(pTHX_ HV *hv) hfreeentries(hv); if (name) { - if(PL_stashcache) - hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); + 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; @@ -1893,6 +1800,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); @@ -1932,6 +1841,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"); @@ -1956,6 +1869,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"); @@ -1967,6 +1882,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"); @@ -1978,6 +1895,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"); @@ -1996,6 +1915,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"); @@ -2019,6 +1940,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) @@ -2042,7 +1964,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); } @@ -2050,6 +1975,8 @@ void Perl_hv_kill_backrefs(pTHX_ HV *hv) { AV *av; + PERL_ARGS_ASSERT_HV_KILL_BACKREFS; + if (!SvOOK(hv)) return; @@ -2100,6 +2027,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"); @@ -2224,6 +2153,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); @@ -2250,6 +2181,8 @@ see C. SV * Perl_hv_iterkeysv(pTHX_ register HE *entry) { + PERL_ARGS_ASSERT_HV_ITERKEYSV; + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } @@ -2265,6 +2198,8 @@ 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)) { SV* const sv = sv_newmortal(); @@ -2292,6 +2227,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); @@ -2438,6 +2375,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; @@ -2465,6 +2404,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: @@ -2474,7 +2416,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]; @@ -2548,6 +2490,8 @@ Perl_hv_placeholders_p(pTHX_ HV *hv) dVAR; MAGIC *mg = mg_find((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); @@ -2565,6 +2509,8 @@ Perl_hv_placeholders_get(pTHX_ HV *hv) dVAR; MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET; + return mg ? mg->mg_len : 0; } @@ -2574,6 +2520,8 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) dVAR; MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; + if (mg) { mg->mg_len = ph; } else if (ph) { @@ -2588,6 +2536,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); @@ -2800,21 +2751,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((SV*)value) ? HVrhek_UV : HVrhek_IV; } else if (value == &PL_sv_placeholder) { value_type = HVrhek_delete; } else if (!SvOK(value)) { @@ -2824,13 +2772,42 @@ 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); +} + +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*) PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 @@ -2842,33 +2819,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((SV *)value); + } else if (value_type == HVrhek_UV) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX((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 @@ -2927,6 +2888,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 @@ -2949,6 +2953,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))) {