From: Nicholas Clark Date: Mon, 13 Jun 2005 20:18:57 +0000 (+0000) Subject: Croak if an attempt is made to modify PL_strtab X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5d2b148555a8ecf68ab82784915f0877e3c9783a;p=p5sagit%2Fp5-mst-13.2.git Croak if an attempt is made to modify PL_strtab (er, TODO - these should be in perldiag) p4raw-id: //depot/perl@24827 --- 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) {