Subject: [PATCH] Hash::Util & restricted hash touch up, part 1

   Date: Sun, 10 Mar 2002 13:27:12 -0500
   Message-Id: <20020310182712.GC693@blackrider>

   Subject: [PATCH] Hash::Util part 2
   From: Michael G Schwern <schwern@pobox.com>
   Date: Sun, 10 Mar 2002 15:09:34 -0500
   Message-Id: <20020310200934.GB27112@blackrider>

   Subject: [PATCH] Hash::Util MANIFEST correction
   From: Michael G Schwern <schwern@pobox.com>
   Date: Sun, 10 Mar 2002 16:27:07 -0500
   Message-Id: <20020310212707.GF27112@blackrider>

   (Also changes find.t and taint.t, which were looking for access.t)

p4raw-id: //depot/perl@15166

15 files changed, 659 insertions, 125 deletions

diff --git a/MANIFEST b/MANIFEST
index f18186fb17..5ba6957153 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -127,6 +127,13 @@ ext/Data/Dumper/Makefile.PL	Data pretty printer, makefile writer
 ext/Data/Dumper/t/dumper.t	See if Data::Dumper works
 ext/Data/Dumper/t/overload.t	See if Data::Dumper works for overloaded data
 ext/Data/Dumper/Todo		Data pretty printer, futures
+ext/Data/Util/Changes           Data/Hash::Util, Change log
+ext/Data/Util/Makefile.PL       Data/Hash::Util, Makefile.PL
+ext/Data/Util/Util.xs           Data/Hash::Util, Data::Util XS code
+ext/Data/Util/lib/Data/Util.pm  Data/Hash::Util, Data::Util
+ext/Data/Util/lib/Hash/Util.pm  Data/Hash::Util, Hash::Util
+ext/Data/Util/t/Data.t          Data/Hash::Util, Data::Util test
+ext/Data/Util/t/Hash.t          Data/Hash::Util, Hash::Util test
 ext/DB_File/Changes	Berkeley DB extension change log
 ext/DB_File/dbinfo	Berkeley DB database version checker
 ext/DB_File/DB_File.pm	Berkeley DB extension Perl module
@@ -2171,7 +2178,6 @@ t/io/read.t			See if read works
 t/io/tell.t			See if file seeking works
 t/io/utf8.t			See if file seeking works
 t/lib/1_compile.t		See if the various libraries and extensions compile
-t/lib/access.t			See if access::readonly and readonly hashes work
 t/lib/commonsense.t		See if configuration meets basic needs
 t/lib/compmod.pl		Helper for 1_compile.t
 t/lib/dprof/test1_t		Perl code profiler tests
diff --git a/ext/Data/Util/Changes b/ext/Data/Util/Changes
new file mode 100644
index 0000000000..f877d08678
--- /dev/null
+++ b/ext/Data/Util/Changes
@@ -0,0 +1,27 @@
+0.04  Sun Mar 10 13:37:08 EST 2002
+  * Bugs in the restricted hash implementation have been fixed.  All
+    tests should pass on a perl sometime after about 15160
+  * Minimum version is now 5.7.3
+  - Changed diagnostic expecations to match new restricted hash 
+    diagnostics.
+
+0.03  Sat Mar  9 20:11:00 EST 2002
+  *** NOTE *** There are known failures in t/Hash.t.  These are
+  due to bugs in perl's restricted hash implementation.  They have
+  been left failing so Those That Know How To Fix It know where
+  the bugs are.
+
+  * Data::Util::readonly() is now sv_readonly_flag() to make its
+    function less ambiguous.
+  * Hash::Util::lock_key/unlock_key is now lock_value/unlock_value
+    to make its functionality less ambiguous.  It also takes
+    somewhat different arguments.
+  * Added lock_hash(), unlock_hash().
+
+0.02  Wed Feb 27 23:35:58 EST 2002
+  * lock_keys(%hash, @keys) implemented
+  * tarball name changed to the somewhat more proper Data-Hash-Utils
+
+0.01  Tue Feb 26 23:18:03 EST 2002
+  - First released version
+  - There are some failures at the end of Hash.t
diff --git a/ext/Data/Util/Makefile.PL b/ext/Data/Util/Makefile.PL
new file mode 100644
index 0000000000..ef6bc3c3ab
--- /dev/null
+++ b/ext/Data/Util/Makefile.PL
@@ -0,0 +1,53 @@
+# A template for Makefile.PL.
+# - Set the $PACKAGE variable to the name of your module.
+# - Set $LAST_API_CHANGE to reflect the last version you changed the API 
+#   of your module.
+# - Fill in your dependencies in PREREQ_PM
+# Alternatively, you can say the hell with this and use h2xs.
+
+require 5.007003;
+
+use ExtUtils::MakeMaker;
+
+$PACKAGE = 'Data::Util';
+($PACKAGE_FILE = $PACKAGE) =~ s|::|/|g;
+$LAST_API_CHANGE = 0.03;
+
+eval "require $PACKAGE";
+
+unless ($@) { # Make sure we did find the module.
+    print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE;
+
+NOTE: There have been API changes between this version and any older
+than version $LAST_API_CHANGE!  Please read the Changes file if you
+are upgrading from a version older than $LAST_API_CHANGE.
+
+CHANGE_WARN
+}
+
+WriteMakefile(
+    NAME            => $PACKAGE,
+    DISTNAME        => 'Data-Hash-Utils',
+    VERSION_FROM    => "lib/$PACKAGE_FILE.pm", # finds $VERSION
+    PREREQ_PM       => {   },
+);
+
+
+{
+    package MY;
+
+    sub test_via_harness {
+        my($self, $orig_perl, $tests) = @_;
+
+        my @perls = ($orig_perl);
+        push @perls, qw(bleadperl)
+          if $ENV{PERL_TEST_ALL};
+
+        my $out;
+        foreach my $perl (@perls) {
+            $out .= $self->SUPER::test_via_harness($perl, $tests);
+        }
+
+        return $out;
+    }
+}
diff --git a/ext/Data/Util/Util.xs b/ext/Data/Util/Util.xs
new file mode 100644
index 0000000000..6d246ddf51
--- /dev/null
+++ b/ext/Data/Util/Util.xs
@@ -0,0 +1,29 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+MODULE=Data::Util   PACKAGE=Data::Util
+
+int
+sv_readonly_flag(...)
+PROTOTYPE: \[$%@];$
+CODE:
+{
+    SV *sv = SvRV(ST(0));
+    IV old = SvREADONLY(sv);
+
+    if (items == 2) {
+        if (SvTRUE(ST(1))) {
+            SvREADONLY_on(sv);
+        }
+        else {
+            SvREADONLY_off(sv);
+        }
+    }
+    if (old)
+        XSRETURN_YES;
+    else
+        XSRETURN_NO;
+}
+
diff --git a/ext/Data/Util/lib/Data/Util.pm b/ext/Data/Util/lib/Data/Util.pm
new file mode 100644
index 0000000000..26e2993a9b
--- /dev/null
+++ b/ext/Data/Util/lib/Data/Util.pm
@@ -0,0 +1,73 @@
+package Data::Util;
+
+require Exporter;
+require DynaLoader;
+
+our @ISA        = qw(Exporter DynaLoader);
+our @EXPORT_OK  = qw(sv_readonly_flag);
+our $VERSION    = 0.04;
+
+bootstrap Data::Util $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Data::Util - A selection of general-utility data subroutines
+
+=head1 SYNOPSIS
+
+  use Data::Util qw(sv_readonly_flag);
+
+  my $sv_readonly = sv_readonly_flag(%some_data);
+
+  sv_readonly_flag(@some_data, 1);  # Set the sv_readonly flag on
+                                    # @some_data to true.
+
+=head1 DESCRIPTION
+
+C<Data::Util> contains a selection of subroutines which are useful on
+scalars, hashes and lists (and thus wouldn't fit into Scalar, Hash or
+List::Util).  All of the routines herein will work equally well on a
+scalar, hash, list or even hash & list elements.
+
+    sv_readonly_flag($some_data);
+    sv_readonly_flag(@some_data);
+    sv_readonly_flag(%some_data);
+    sv_readonly_flag($some_data{key});
+    sv_readonly_flag($some_data[3]);
+
+We'll just refer to the conglomeration as "DATA".
+
+By default C<Data::Util> does not export any subroutines.  You can ask
+for...
+
+=over 4
+
+=item sv_readonly_flag
+
+  my $sv_readonly = sv_readonly_flag(DATA);
+  sv_readonly_flag(DATA, 1);    # set sv_readonly true
+  sv_readonly_flag(DATA, 0);    # set sv_readonly false
+
+This gets/sets the sv_readonly flag on the given DATA.  When setting
+it returns the previous state of the flag.  This is intended for
+people I<that know what they're doing.>
+
+The exact behavior exhibited by a piece of DATA when sv_readonly is
+set depends on what type of data it is.  B<It doesn't even necessarily
+make the data readonly!>  Look for specific functions in Scalar::Util,
+List::Util and Hash::Util for making those respective types readonly.
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> using XS code by Nick Ing-Simmons.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>
+
+=cut
+
diff --git a/ext/Data/Util/lib/Hash/Util.pm b/ext/Data/Util/lib/Hash/Util.pm
new file mode 100644
index 0000000000..c54fbdc0d1
--- /dev/null
+++ b/ext/Data/Util/lib/Hash/Util.pm
@@ -0,0 +1,191 @@
+package Hash::Util;
+
+require 5.007003;
+use strict;
+use Data::Util qw(sv_readonly_flag);
+use Carp;
+
+require Exporter;
+our @ISA        = qw(Exporter);
+our @EXPORT_OK  = qw(lock_keys unlock_keys lock_value unlock_value
+                     lock_hash unlock_hash
+                    );
+our $VERSION    = 0.04;
+
+
+=head1 NAME
+
+Hash::Util - A selection of general-utility hash subroutines
+
+=head1 SYNOPSIS
+
+  use Hash::Util qw(lock_keys   unlock_keys 
+                    lock_value  unlock_value
+                    lock_hash   unlock_hash
+                   );
+
+  %hash = (foo => 42, bar => 23);
+  lock_keys(%hash);
+  lock_keys(%hash, @keyset);
+  unlock_keys(%hash);
+
+  lock_value  (%hash, 'foo');
+  unlock_value(%hash, 'foo');
+
+  lock_hash  (%hash);
+  unlock_hash(%hash);
+
+
+=head1 DESCRIPTION
+
+C<Hash::Util> contains special functions for manipulating hashes that
+don't really warrant a keyword.
+
+By default C<Hash::Util> does not export anything.
+
+=head2 Restricted hashes
+
+5.8.0 introduces the ability to restrict a hash to a certain set of
+keys.  No keys outside of this set can be added.  It also introduces
+the ability to lock an individual key so it cannot be deleted and the
+value cannot be changed.
+
+This is intended to largely replace the deprecated pseudo-hashes.
+
+=over 4
+
+=item lock_keys
+
+=item unlock_keys
+
+  lock_keys(%hash);
+  lock_keys(%hash, @keys);
+
+  unlock_keys(%hash;)
+
+Restricts the given %hash's set of keys to @keys.  If @keys is not
+given it restricts it to its current keyset.  No more keys can be
+added.  delete() and exists() will still work, but it does not effect
+the set of allowed keys.
+
+Removes the restriction on the %hash's keyset.
+
+=cut
+
+sub lock_keys (\%;@) {
+    my($hash, @keys) = @_;
+
+    if( @keys ) {
+        my %keys = map { ($_ => 1) } @keys;
+        my %original_keys = map { ($_ => 1) } keys %$hash;
+        foreach my $k (keys %original_keys) {
+            die sprintf "Hash has key '$k' which is not in the new key ".
+                        "set at %s line %d\n", (caller)[1,2]
+              unless $keys{$k};
+        }
+    
+        foreach my $k (@keys) {
+            $hash->{$k} = undef unless exists $hash->{$k};
+        }
+        sv_readonly_flag %$hash, 1;
+
+        foreach my $k (@keys) {
+            delete $hash->{$k} unless $original_keys{$k};
+        }
+    }
+    else {
+        sv_readonly_flag %$hash, 1;
+    }
+
+    return undef;
+}
+
+sub unlock_keys (\%) {
+    my($hash) = shift;
+
+    sv_readonly_flag %$hash, 0;
+    return undef;
+}
+
+=item lock_value
+
+=item unlock_value
+
+  lock_key  (%hash, $key);
+  unlock_key(%hash, $key);
+
+Locks and unlocks an individual key of a hash.  The value of a locked
+key cannot be changed.
+
+%hash must have already been locked for this to have useful effect.
+
+=cut
+
+sub lock_value (\%$) {
+    my($hash, $key) = @_;
+    carp "Cannot usefully lock values in an unlocked hash" 
+      unless sv_readonly_flag %$hash;
+    sv_readonly_flag $hash->{$key}, 1;
+}
+
+sub unlock_value (\%$) {
+    my($hash, $key) = @_;
+    sv_readonly_flag $hash->{$key}, 0;
+}
+
+
+=item B<lock_hash>
+
+=item B<unlock_hash>
+
+    lock_hash(%hash);
+    unlock_hash(%hash);
+
+lock_hash() locks an entire hash, making all keys and values readonly.
+No value can be changed, no keys can be added or deleted.
+
+unlock_hash() does the opposite.  All keys and values are made
+read/write.  All values can be changed and keys can be added and
+deleted.
+
+=cut
+
+sub lock_hash (\%) {
+    my($hash) = shift;
+
+    lock_keys(%$hash);
+
+    foreach my $key (keys %$hash) {
+        lock_value(%$hash, $key);
+    }
+
+    return 1;
+}
+
+sub unlock_hash (\%) {
+    my($hash) = shift;
+
+    foreach my $key (keys %$hash) {
+        unlock_value(%$hash, $key);
+    }
+
+    unlock_keys(%$hash);
+
+    return 1;
+}
+
+
+=back
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> on top of code by Nick
+Ing-Simmons and Jeffrey Friedl.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>
+
+=cut
+
+1;
diff --git a/ext/Data/Util/t/Data.t b/ext/Data/Util/t/Data.t
new file mode 100644
index 0000000000..6198c3a9f3
--- /dev/null
+++ b/ext/Data/Util/t/Data.t
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        @INC = '../lib';
+        chdir 't';
+    }
+}
+use Test::More tests => 26;
+
+use Data::Util;
+BEGIN { use_ok 'Data::Util', qw(sv_readonly_flag); }
+
+ok( !sv_readonly_flag $foo );
+ok( !sv_readonly_flag $foo, 1 );
+ok( sv_readonly_flag $foo );
+ok( sv_readonly_flag $foo, 0 );
+ok( !sv_readonly_flag $foo );
+
+ok( !sv_readonly_flag @foo );
+ok( !sv_readonly_flag @foo, 1 );
+ok( sv_readonly_flag @foo );
+ok( sv_readonly_flag @foo, 0 );
+ok( !sv_readonly_flag @foo );
+
+ok( !sv_readonly_flag $foo[2] );
+ok( !sv_readonly_flag $foo[2], 1 );
+ok( sv_readonly_flag $foo[2] );
+ok( sv_readonly_flag $foo[2], 0 );
+ok( !sv_readonly_flag $foo[2] );
+
+ok( !sv_readonly_flag %foo );
+ok( !sv_readonly_flag %foo, 1 );
+ok( sv_readonly_flag %foo );
+ok( sv_readonly_flag %foo, 0 );
+ok( !sv_readonly_flag %foo );
+
+ok( !sv_readonly_flag $foo{foo} );
+ok( !sv_readonly_flag $foo{foo}, 1 );
+ok( sv_readonly_flag $foo{foo} );
+ok( sv_readonly_flag $foo{foo}, 0 );
+ok( !sv_readonly_flag $foo{foo} );
diff --git a/ext/Data/Util/t/Hash.t b/ext/Data/Util/t/Hash.t
new file mode 100644
index 0000000000..b1f9e79304
--- /dev/null
+++ b/ext/Data/Util/t/Hash.t
@@ -0,0 +1,171 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        @INC = '../lib';
+        chdir 't';
+    }
+}
+use Test::More tests => 45;
+use Data::Util qw(sv_readonly_flag);
+
+my @Exported_Funcs;
+BEGIN { 
+    @Exported_Funcs = qw(lock_keys   unlock_keys
+                         lock_value  unlock_value
+                         lock_hash   unlock_hash
+                        );
+    use_ok 'Hash::Util', @Exported_Funcs;
+}
+foreach my $func (@Exported_Funcs) {
+    can_ok __PACKAGE__, $func;
+}
+
+my %hash = (foo => 42, bar => 23, locked => 'yep');
+lock_keys(%hash);
+eval { $hash{baz} = 99; };
+like( $@, qr/^Attempt to access disallowed key 'baz' in a fixed hash/,
+                                                       'lock_keys()');
+is( $hash{bar}, 23 );
+ok( !exists $hash{baz} );
+
+delete $hash{bar};
+ok( !exists $hash{bar} );
+$hash{bar} = 69;
+is( $hash{bar}, 69 );
+
+eval { () = $hash{i_dont_exist} };
+like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a fixed hash/ );
+
+lock_value(%hash, 'locked');
+eval { print "# oops" if $hash{four} };
+like( $@, qr/^Attempt to access disallowed key 'four' in a fixed hash/ );
+
+eval { $hash{"\x{2323}"} = 3 };
+like( $@, qr/^Attempt to access disallowed key '(.*)' in a fixed hash/,
+                                               'wide hex key' );
+
+eval { delete $hash{locked} };
+like( $@, qr/^Attempt to delete readonly key 'locked' from a fixed hash/,
+                                           'trying to delete a locked key' );
+eval { $hash{locked} = 42; };
+like( $@, qr/^Modification of a read-only value attempted/,
+                                           'trying to change a locked key' );
+is( $hash{locked}, 'yep' );
+
+eval { delete $hash{I_dont_exist} };
+like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a fixed hash/,
+                             'trying to delete a key that doesnt exist' );
+
+ok( !exists $hash{I_dont_exist} );
+
+unlock_keys(%hash);
+$hash{I_dont_exist} = 42;
+is( $hash{I_dont_exist}, 42,    'unlock_keys' );
+
+eval { $hash{locked} = 42; };
+like( $@, qr/^Modification of a read-only value attempted/,
+                             '  individual key still readonly' );
+eval { delete $hash{locked} },
+is( $@, '', '  but can be deleted :(' );
+
+unlock_value(%hash, 'locked');
+$hash{locked} = 42;
+is( $hash{locked}, 42,  'unlock_value' );
+
+
+TODO: {
+#    local $TODO = 'assigning to a hash screws with locked keys';
+
+    my %hash = ( foo => 42, locked => 23 );
+
+    lock_keys(%hash);
+    lock_value(%hash, 'locked');
+    eval { %hash = ( wubble => 42 ) };  # we know this will bomb
+    like( $@, qr/^Attempt to clear a fixed hash/ );
+
+    eval { unlock_value(%hash, 'locked') }; # but this shouldn't
+    is( $@, '', 'unlock_value() after denied assignment' );
+
+    is_deeply( \%hash, { foo => 42, locked => 23 },
+                      'hash should not be altered by denied assignment' );
+    unlock_keys(%hash);
+}
+
+{ 
+    my %hash = (KEY => 'val', RO => 'val');
+    lock_keys(%hash);
+    lock_value(%hash, 'RO');
+
+    eval { %hash = (KEY => 1) };
+    like( $@, qr/^Attempt to clear a fixed hash/ );
+}
+
+# TODO:  This should be allowed but it might require putting extra
+#        code into aassign.
+{
+    my %hash = (KEY => 1, RO => 2);
+    lock_keys(%hash);
+    eval { %hash = (KEY => 1, RO => 2) };
+    like( $@, qr/^Attempt to clear a fixed hash/ );
+}
+
+
+
+{
+    my %hash = ();
+    lock_keys(%hash, qw(foo bar));
+    is( keys %hash, 0,  'lock_keys() w/keyset shouldnt add new keys' );
+    $hash{foo} = 42;
+    is( keys %hash, 1 );
+    eval { $hash{wibble} = 42 };
+    like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/,
+                        '  locked');
+
+    unlock_keys(%hash);
+    eval { $hash{wibble} = 23; };
+    is( $@, '', 'unlock_keys' );
+}
+
+
+{
+    my %hash = (foo => 42, bar => undef, baz => 0);
+    lock_keys(%hash, qw(foo bar baz up down));
+    is( keys %hash, 3,   'lock_keys() w/keyset didnt add new keys' );
+    is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
+
+    eval { $hash{up} = 42; };
+    is( $@, '' );
+
+    eval { $hash{wibble} = 23 };
+    like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/, '  locked' );
+}
+
+
+{
+    my %hash = (foo => 42, bar => undef);
+    eval { lock_keys(%hash, qw(foo baz)); };
+    is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
+                    "set at %s line %d\n", __FILE__, __LINE__ - 2) );
+}
+
+
+{
+    my %hash = (foo => 42, bar => 23);
+    lock_hash( %hash );
+
+    ok( sv_readonly_flag(%hash) );
+    ok( sv_readonly_flag($hash{foo}) );
+    ok( sv_readonly_flag($hash{bar}) );
+
+    unlock_hash ( %hash );
+
+    ok( !sv_readonly_flag(%hash) );
+    ok( !sv_readonly_flag($hash{foo}) );
+    ok( !sv_readonly_flag($hash{bar}) );
+}
+
+
+lock_keys(%ENV);
+eval { () = $ENV{I_DONT_EXIST} };
+like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a fixed hash/,   'locked %ENV');
diff --git a/hv.c b/hv.c
index df6c2d1c02..41aa8bbe54 100644
--- a/hv.c
+++ b/hv.c
@@ -133,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) {
@@ -147,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 key '%"SVf"' in fixed hash",sv);
+    Perl_croak(aTHX_ msg, sv);
 }
 
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
@@ -266,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);
@@ -400,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);
@@ -523,7 +527,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();
@@ -644,7 +650,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();
@@ -770,7 +778,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 	    }
 	}
 	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)
@@ -804,7 +814,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 	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)
@@ -912,7 +924,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            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)
@@ -946,7 +960,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 	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)
@@ -1446,6 +1462,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 */
diff --git a/lib/File/Find/t/find.t b/lib/File/Find/t/find.t
index c74a646439..745c6efe57 100644
--- a/lib/File/Find/t/find.t
+++ b/lib/File/Find/t/find.t
@@ -51,10 +51,10 @@ BEGIN {
 
 cleanup();
 
-find({wanted => sub { print "ok 1\n" if $_ eq 'access.t'; } },
+find({wanted => sub { print "ok 1\n" if $_ eq '1_compile.t'; } },
    File::Spec->curdir);
 
-finddepth({wanted => sub { print "ok 2\n" if $_ eq 'access.t'; } },
+finddepth({wanted => sub { print "ok 2\n" if $_ eq '1_compile.t'; } },
 	File::Spec->curdir);
 
 
diff --git a/lib/File/Find/t/taint.t b/lib/File/Find/t/taint.t
index 2c76138144..cef13a1191 100644
--- a/lib/File/Find/t/taint.t
+++ b/lib/File/Find/t/taint.t
@@ -49,16 +49,16 @@ use Cwd;
 cleanup();
 
 my $found;
-find({wanted => sub { $found = 1 if ($_ eq 'access.t') },
+find({wanted => sub { $found = 1 if ($_ eq '1_compile.t') },
 		untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
 
-ok($found, 'access.t found');
+ok($found, '1_compile.t found');
 $found = 0;
 
-finddepth({wanted => sub { $found = 1 if $_ eq 'access.t'; },
+finddepth({wanted => sub { $found = 1 if $_ eq '1_compile.t'; },
            untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
 
-ok($found, 'access.t found again');
+ok($found, '1_compile.t found again');
 
 my $case = 2;
 my $FastFileTests_OK = 0;
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3cd4ece052..c86ed26e5a 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -183,12 +183,26 @@ spots.  This is now heavily deprecated.
 must either both be scalars or both be lists.  Otherwise Perl won't
 know which context to supply to the right side.
 
-=item Attempt to access key '%_' in fixed hash
+=item Attempt to access disallowed key '%s' in a fixed hash
 
-(F) A hash has been marked as READONLY at the C level to turn it
-into a "record" with a fixed set of keys. The failing code
-has attempted to get or set the value of a key which does not
-exist or to delete a key.
+(F) The failing code has attempted to get or set a key which is not in
+the current set of allowed keys of a fixed hash.
+
+=item Attempt to clear a fixed hash
+
+(F) It is currently not allowed to clear a fixed hash, even if the
+new hash would contain the same keys as before.  This may change in
+the future.
+
+=item Attempt to delete readonly key '%s' from a fixed hash
+
+(F) The failing code attempted to delete a key whose value has been
+declared readonly from a fixed hash.
+
+=item Attempt to delete disallowed key '%s' from a fixed hash
+
+(F) The failing code attempted to delete from a fixed hash a key which
+is not in its key set.
 
 =item Attempt to bless into a reference
 
diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index 2f840555fb..9695e6d44c 100644
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -525,6 +525,16 @@ Instead of having to guess whether a string is a v-string and thus
 needs to be displayed with %vd, make v-strings (readonly) objects
 (class "vstring"?) with a stringify overload.
 
+=head2 Allow restricted hash assignment
+
+Currently you're not allowed to assign to a restricted hash at all,
+even with the same keys.
+
+    %restricted = (foo => 42);  # error
+
+This should be allowed if the new keyset is a subset of the old
+keyset.  May require more extra code than we'd like in pp_aassign.
+
 =head1 Vague ideas
 
 Ideas which have been discussed, and which may or may not happen.
diff --git a/t/lib/access.t b/t/lib/access.t
deleted file mode 100644
index da7193e6d4..0000000000
--- a/t/lib/access.t
+++ /dev/null
@@ -1,82 +0,0 @@
-#!./perl
-
-BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-}
-
-$| = 1;
-print "1..19\n";
-
-my $t = 1;
-
-sub ok
-{
- my $val = shift;
- if ($val)
-  {
-   print "ok $t\n";
-  }
- else
-  {
-   my ($pack,$file,$line) = caller;
-   print "not ok $t # $file:$line\n";
-  }
- $t++;
-}
-
-my %hash = ( one => 1, two => 2);;
-ok(!access::readonly(%hash));
-
-ok(!access::readonly(%hash,1));
-
-ok(!access::readonly($hash{two},1));
-
-eval { $hash{'three'} = 3 };
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'three' in fixed hash/);
-
-eval { print "# oops"  if $hash{'four'}};
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'four' in fixed hash/);
-
-eval { $hash{"\x{2323}"} = 3 };
-#warn "$@";
-ok($@ =~ /^Attempt to access key '(.*)' in fixed hash/);
-#ok(ord($1) == 0x2323);
-
-eval { delete $hash{'two'}};
-#warn "$@";
-ok($@);
-
-eval { delete $hash{'one'}};
-ok(not $@);
-
-ok($hash{two} == 2);
-
-eval { delete $hash{'four'}};
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'four' in fixed hash/);
-
-ok(not exists $hash{'one'});
-
-ok(!exists $hash{'three'});
-
-ok(access::readonly(%hash,0));
-
-ok(!access::readonly(%hash));
-
-my $scalar = 1;
-ok(!access::readonly($scalar));
-
-ok(!access::readonly($scalar,1));
-
-eval { $scalar++ };
-#warn $@;
-ok($@ =~ /^Modification of a read-only value attempted/);
-
-ok(access::readonly($scalar,0));
-
-ok(!access::readonly($scalar));
-
-
diff --git a/universal.c b/universal.c
index aeec350f5e..ae12e27984 100644
--- a/universal.c
+++ b/universal.c
@@ -167,7 +167,6 @@ XS(XS_utf8_upgrade);
 XS(XS_utf8_downgrade);
 XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
-XS(XS_access_readonly);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -184,7 +183,6 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("utf8::downgrade", XS_utf8_downgrade, file);
     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
-    newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
 }
 
 
@@ -460,22 +458,3 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
-XS(XS_access_readonly)
-{
-    dXSARGS;
-    SV *sv = SvRV(ST(0));
-    IV old = SvREADONLY(sv);
-    if (items == 2) {
-	if (SvTRUE(ST(1))) {
-	    SvREADONLY_on(sv);
-	}
-	else {
-	    SvREADONLY_off(sv);
-	}
-    }
-    if (old)
-	XSRETURN_YES;
-    else
-	XSRETURN_NO;
-}
-