From 5d2b148555a8ecf68ab82784915f0877e3c9783a Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 13 Jun 2005 20:18:57 +0000
Subject: [PATCH] Croak if an attempt is made to modify PL_strtab (er, TODO -
 these should be in perldiag)

p4raw-id: //depot/perl@24827
---
 ext/XS/APItest/APItest.pm |  4 ++--
 ext/XS/APItest/APItest.xs |  7 +++++++
 ext/XS/APItest/t/hash.t   | 26 ++++++++++++++++++++++++++
 hv.c                      | 25 +++++++++++++++++++++++++
 4 files changed, 60 insertions(+), 2 deletions(-)

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 3794528..e905948 100644
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -19,7 +19,7 @@ our @EXPORT = qw( print_double print_int print_long
 		  call_sv call_pv call_method eval_sv eval_pv require_pv
 		  G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
 		  G_KEEPERR G_NODEBUG G_METHOD
-		  exception mycroak
+		  exception mycroak strtab
 );
 
 # from cop.h 
@@ -33,7 +33,7 @@ sub G_KEEPERR()	{  16 }
 sub G_NODEBUG()	{  32 }
 sub G_METHOD()	{  64 }
 
-our $VERSION = '0.06';
+our $VERSION = '0.07';
 
 bootstrap XS::APItest $VERSION;
 
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index db85db3..446ebe0 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -338,3 +338,10 @@ mycroak(pv)
     const char* pv
     CODE:
     Perl_croak(aTHX_ "%s", pv);
+
+SV*
+strtab()
+   CODE:
+   RETVAL = newRV_inc((SV*)PL_strtab);
+   OUTPUT:
+   RETVAL
diff --git a/ext/XS/APItest/t/hash.t b/ext/XS/APItest/t/hash.t
index 5c6398a..54da2b9 100644
--- a/ext/XS/APItest/t/hash.t
+++ b/ext/XS/APItest/t/hash.t
@@ -55,6 +55,32 @@ main_tests (\@keys, \@testkeys, ' [utf8 hash]');
       "hv_store doesn't insert a key with the raw utf8 on a tied hash");
 }
 
+{
+    my $strtab = strtab();
+    is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
+    eval {
+	$strtab->{wibble}++;
+    };
+    my $prefix = "Cannot modify shared string table in hv_";
+    my $what = $prefix . 'fetch';
+    like ($@, qr/^$what/,$what);
+    eval {
+	XS::APItest::Hash::store($strtab, 'Boom!',  1)
+    };
+    $what = $prefix . 'store';
+    like ($@, qr/^$what/, $what);
+    if (0) {
+	A::B->method();
+    }
+    # DESTROY should be in there.
+    eval {
+	delete $strtab->{DESTROY};
+    };
+    $what = $prefix . 'delete';
+    like ($@, qr/^$what/, $what);
+    # I can't work out how to get to the code that flips the wasutf8 flag on
+    # the hash key without some ikcy XS
+}
 exit;
 
 ################################   The End   ################################
diff --git a/hv.c b/hv.c
index 3d2e589..0157886 100644
--- a/hv.c
+++ b/hv.c
@@ -33,6 +33,9 @@ holds the key and hash value.
 
 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
 
+static const char *const S_strtab_error
+    = "Cannot modify shared string table in hv_%s";
+
 STATIC void
 S_more_he(pTHX)
 {
@@ -692,6 +695,14 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 		    unshare_hek (HeKEY_hek(entry));
 		    HeKEY_hek(entry) = new_hek;
 		}
+		else if (hv == PL_strtab) {
+		    /* PL_strtab is usually the only hash without HvSHAREKEYS,
+		       so putting this test here is cheap  */
+		    if (flags & HVhek_FREEKEY)
+			Safefree(key);
+		    Perl_croak(aTHX_ S_strtab_error,
+			       action & HV_FETCH_LVALUE ? "fetch" : "store");
+		}
 		else
 		    HeKFLAGS(entry) = masked_flags;
 		if (masked_flags & HVhek_ENABLEHVKFLAGS)
@@ -793,6 +804,14 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
        bad API design.  */
     if (HvSHAREKEYS(hv))
 	HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
+    else if (hv == PL_strtab) {
+	/* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
+	   this test here is cheap  */
+	if (flags & HVhek_FREEKEY)
+	    Safefree(key);
+	Perl_croak(aTHX_ S_strtab_error,
+		   action & HV_FETCH_LVALUE ? "fetch" : "store");
+    }
     else                                       /* gotta do the real thing */
 	HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
     HeVAL(entry) = val;
@@ -1036,6 +1055,12 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 	    continue;
 
+	if (hv == PL_strtab) {
+	    if (k_flags & HVhek_FREEKEY)
+		Safefree(key);
+	    Perl_croak(aTHX_ S_strtab_error, "delete");
+	}
+
 	/* if placeholder is here, it's already been deleted.... */
 	if (HeVAL(entry) == &PL_sv_placeholder)
 	{
-- 
2.7.4