X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=95df7c8fb4e2638a1d56dcfda30abcf2cb8ae3f3;hb=869efde7048cf4e4bafcc463f8d4209a63e0d41a;hp=1bde70e3cdd76ce340c999461f9a6d4734b7f085;hpb=324a0d1887cfcef6494645efbaf97082c32ae679;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index 1bde70e..95df7c8 100644 --- a/hv.c +++ b/hv.c @@ -40,12 +40,9 @@ STATIC void S_more_he(pTHX) { dVAR; - HE* he; - HE* heend; - - he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT); + HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT); + HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1]; - heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1]; PL_body_roots[HE_SVSLOT] = he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); @@ -239,39 +236,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 @@ -297,43 +261,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 @@ -344,30 +276,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 @@ -377,14 +285,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 */ /* @@ -404,16 +304,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_fetch_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), NULL, hash); + 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, 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; @@ -422,13 +333,41 @@ 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))) { + 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); + } + + mg->mg_obj = keysv; /* pass key */ + uf->uf_index = action; /* pass action */ + magic_getuvar((SV*)hv, mg); + keysv = mg->mg_obj; /* may have changed */ + mg->mg_obj = obj; + + /* If the key may have changed, then we need to invalidate + any passed-in computed hash value. */ + hash = 0; + } + } + } if (keysv) { - if (SvSMAGICAL(hv) && SvGMAGICAL(hv)) - keysv = hv_magic_uvar_xkey(hv, keysv, action); if (flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); @@ -438,12 +377,18 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); } + if (action & HV_DELETE) { + 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)) { - /* 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); @@ -478,7 +423,10 @@ S_hv_fetch_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)) { @@ -490,23 +438,27 @@ 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 */, - 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, - 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 @@ -535,7 +487,7 @@ 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)) { @@ -624,7 +576,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (flags & HVhek_FREEKEY) Safefree(key); - return 0; + return NULL; } } @@ -740,6 +692,9 @@ 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 */ @@ -750,8 +705,9 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (env) { sv = newSVpvn(env,len); SvTAINTED_on(sv); - return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv, - hash); + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + sv, hash); } } #endif @@ -765,7 +721,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); @@ -774,8 +730,15 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, which in turn might do some tied magic. So we need to make that magic check happen. */ /* gonna assign to this, so it better be there */ - return hv_fetch_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE, val, hash); + /* If a fetch-as-store fails on the fetch, then the action is to + recurse once into "hv_store". If we didn't do this, then that + recursive call would call the key conversion routine again. + 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_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. */ } @@ -846,7 +809,10 @@ 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 @@ -904,26 +870,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 hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0); -} - -/* =for apidoc hv_delete_ent Deletes a key/value pair in the hash. The value SV is removed from the @@ -934,13 +880,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 hv_delete_common(hv, keysv, NULL, 0, 0, flags, 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) @@ -950,24 +889,9 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, register HE *entry; register HE **oentry; HE *const *first_entry; - bool is_utf8; + bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE; int masked_flags; - if (!hv) - return NULL; - - if (keysv) { - if (SvSMAGICAL(hv) && SvGMAGICAL(hv)) - keysv = hv_magic_uvar_xkey(hv, keysv, HV_DELETE); - if (k_flags & HVhek_FREEKEY) - Safefree(key); - key = SvPV_const(keysv, klen); - k_flags = 0; - is_utf8 = (SvUTF8(keysv) != 0); - } else { - is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE); - } - if (SvRMAGICAL(hv)) { bool needs_copy; bool needs_store; @@ -975,9 +899,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, - 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)) { @@ -1124,7 +1049,7 @@ STATIC void S_hsplit(pTHX_ HV *hv) { dVAR; - register XPVHV* xhv = (XPVHV*)SvANY(hv); + register XPVHV* const xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize = oldsize * 2; register I32 i; @@ -1472,9 +1397,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); @@ -1506,8 +1431,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); @@ -1608,6 +1533,8 @@ Perl_hv_clear(pTHX_ HV *hv) HvREHASH_off(hv); reset: if (SvOOK(hv)) { + if(HvNAME_get(hv)) + mro_isa_changed_in(hv); HvEITER_set(hv, NULL); } } @@ -1756,7 +1683,6 @@ S_hfreeentries(pTHX_ HV *hv) 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_isarev) SvREFCNT_dec(meta->mro_isarev); if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); Safefree(meta); iter->xhv_mro_meta = NULL; @@ -1845,10 +1771,14 @@ Perl_hv_undef(pTHX_ HV *hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); + + if ((name = HvNAME_get(hv)) && !PL_dirty) + mro_isa_changed_in(hv); + hfreeentries(hv); - if ((name = HvNAME_get(hv))) { - if(PL_stashcache) - hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); + if (name) { + 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; @@ -2009,7 +1939,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) iter = hv_auxinit(hv); } PERL_HASH(hash, name, len); - iter->xhv_name = name ? share_hek(name, len, hash) : 0; + iter->xhv_name = name ? share_hek(name, len, hash) : NULL; } AV ** @@ -2515,24 +2445,6 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) return HeKEY_hek(entry); } -STATIC SV * -S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action) -{ - MAGIC* mg; - if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) { - struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; - if (uf->uf_set == NULL) { - SV* obj = mg->mg_obj; - mg->mg_obj = keysv; /* pass key */ - uf->uf_index = action; /* pass action */ - magic_getuvar((SV*)hv, mg); - keysv = mg->mg_obj; /* may have changed */ - mg->mg_obj = obj; - } - } - return keysv; -} - I32 * Perl_hv_placeholders_p(pTHX_ HV *hv) {