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

7 files changed, 586 insertions, 0 deletions

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');