X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=f92e31e4275e97882c51c5a06613c52bab0a74d8;hb=0ab125c1e00cef4eab6989366621d77be6d38567;hp=e1387b6bb9c1e70194ff4bd38605ef3c25cfea8f;hpb=be3c0a43e1e6b1244032726df02a3ab450a3c4be;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index e1387b6..f92e31e 100644 --- a/hv.c +++ b/hv.c @@ -85,9 +85,10 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash) is_utf8 = TRUE; } - New(54, k, HEK_BASESIZE + len + 1, char); + New(54, k, HEK_BASESIZE + len + 2, char); hek = (HEK*)k; Copy(str, HEK_KEY(hek), len, char); + HEK_KEY(hek)[len] = 0; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; HEK_UTF8(hek) = (char)is_utf8; @@ -132,7 +133,7 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) static void Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen, - const char *keysave) + const char *keysave, const char *msg) { SV *sv = sv_newmortal(); if (key == keysave) { @@ -146,7 +147,7 @@ Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen, if (is_utf8) { SvUTF8_on(sv); } - Perl_croak(aTHX_ "Attempt to access to key '%"SVf"' in fixed hash",sv); + Perl_croak(aTHX_ msg, sv); } /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot @@ -265,7 +266,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to access disallowed key '%"SVf"' in a fixed hash" + ); } if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); @@ -399,7 +402,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to access disallowed key '%"SVf"' in a fixed hash" + ); } if (key != keysave) Safefree(key); @@ -483,11 +488,13 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has #endif } } + if (is_utf8) { STRLEN tmplen = klen; /* See the note in hv_fetch(). --jhi */ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); klen = tmplen; + HvUTF8KEYS_on((SV*)hv); } if (!hash) @@ -522,7 +529,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to access disallowed key '%"SVf"' to a fixed hash" + ); } entry = new_HE(); @@ -608,8 +617,10 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) keysave = key = SvPV(keysv, klen); is_utf8 = (SvUTF8(keysv) != 0); - if (is_utf8) + if (is_utf8) { key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + HvUTF8KEYS_on((SV*)hv); + } if (!hash) PERL_HASH(hash, key, klen); @@ -643,7 +654,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to access disallowed key '%"SVf"' to a fixed hash" + ); } entry = new_HE(); @@ -764,12 +777,16 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) else hv_free_ent(hv, entry); xhv->xhv_keys--; /* HvKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvUTF8KEYS_off(hv); xhv->xhv_placeholders--; return Nullsv; } } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to delete readonly key '%"SVf"' from a fixed hash" + ); } if (flags & G_DISCARD) @@ -799,11 +816,15 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) else hv_free_ent(hv, entry); xhv->xhv_keys--; /* HvKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvUTF8KEYS_off(hv); } return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to access disallowed key '%"SVf"' from a fixed hash" + ); } if (key != keysave) @@ -907,11 +928,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) else hv_free_ent(hv, entry); xhv->xhv_keys--; /* HvKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvUTF8KEYS_off(hv); xhv->xhv_placeholders--; return Nullsv; } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to delete readonly key '%"SVf"' from a fixed hash" + ); } if (flags & G_DISCARD) @@ -941,11 +966,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) else hv_free_ent(hv, entry); xhv->xhv_keys--; /* HvKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvUTF8KEYS_off(hv); } return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave); + Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave, + "Attempt to delete disallowed key '%"SVf"' from a fixed hash" + ); } if (key != keysave) @@ -1445,6 +1474,11 @@ Perl_hv_clear(pTHX_ HV *hv) register XPVHV* xhv; if (!hv) return; + + if(SvREADONLY(hv)) { + Perl_croak(aTHX_ "Attempt to clear a fixed hash"); + } + xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ @@ -1456,6 +1490,8 @@ Perl_hv_clear(pTHX_ HV *hv) if (SvRMAGICAL(hv)) mg_clear((SV*)hv); + + HvUTF8KEYS_off(hv); } STATIC void @@ -1820,7 +1856,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) if (str != save) Safefree(str); if (!found && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'",str); } /* get a (constant) string ptr from the global string table