X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=11992f45727253d45b9a00e563be0f0f96cd86b6;hb=6aa71d6ea27a640886ba2dcf7250d1be73560df8;hp=d5539209bbb0700d04e42e09a8da81cb9861db4d;hpb=ff875642fb93529394d9c68e02de7dfb16e28ea6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/hv.c b/hv.c
index d553920..11992f4 100644
--- a/hv.c
+++ b/hv.c
@@ -99,7 +99,7 @@ Perl_unshare_hek(pTHX_ HEK *hek)
 
 #if defined(USE_ITHREADS)
 HE *
-Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
+Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
 {
     HE *ret;
 
@@ -126,6 +126,25 @@ Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
 }
 #endif	/* USE_ITHREADS */
 
+static void
+Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
+		   const char *keysave)
+{
+    SV *sv = sv_newmortal();
+    if (key == keysave) {
+	sv_setpvn(sv, key, klen);
+    }
+    else {
+	/* Need to free saved eventually assign to mortal SV */
+	SV *sv = sv_newmortal();
+	sv_usepvn(sv, (char *) key, klen);
+    }
+    if (is_utf8) {
+	SvUTF8_on(sv);
+    }
+    Perl_croak(aTHX_ "Attempt to access to key '%_' in fixed hash",sv);
+}
+
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  * contains an SV* */
 
@@ -135,7 +154,7 @@ Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
 Returns the SV which corresponds to the specified key in the hash.  The
 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 part of a store.  Check that the return value is non-null before
-dereferencing it to a C<SV*>.
+dereferencing it to an C<SV*>.
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
@@ -237,6 +256,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
 	}
     }
 #endif
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
     if (lval) {		/* gonna assign to this, so it better be there */
 	sv = NEWSV(61,0);
 	if (key != keysave) { /* must be is_utf8 == 0 */
@@ -252,7 +274,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
     return 0;
 }
 
-/* returns a HE * structure with the all fields set */
+/* returns an HE * structure with the all fields set */
 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 /*
 =for apidoc hv_fetch_ent
@@ -365,6 +387,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 	}
     }
 #endif
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
     if (key != keysave)
 	Safefree(key);
     if (lval) {		/* gonna assign to this, so it better be there */
@@ -482,6 +507,10 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
 	return &HeVAL(entry);
     }
 
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     entry = new_HE();
     if (HvSHAREKEYS(hv))
 	HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
@@ -596,6 +625,10 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 	return entry;
     }
 
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     entry = new_HE();
     if (HvSHAREKEYS(hv))
 	HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
@@ -682,6 +715,10 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 	klen = tmplen;
     }
 
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     PERL_HASH(hash, key, klen);
 
     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
@@ -782,6 +819,10 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (is_utf8)
 	key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 
+    if (SvREADONLY(hv)) {
+	Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     if (!hash)
 	PERL_HASH(hash, key, klen);