Part 2 of the Hash::Util patch. This throws Data::Util and Hash::Util
0.04 into ext/Data/Util. This is a "complete" interface to restricted
hashes.
I also forgot to remove t/lib/access.t from the MANIFEST.
Still yet todo is to convert Jeff's original comprehensive test suite.
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/Changes Sun Mar 10 13:41:07 2002
@@ -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
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/Makefile.PL Sun Mar 10 13:41:07 2002
@@ -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;
+ }
+}
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/Util.xs Sun Mar 10 13:41:07 2002
@@ -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;
+}
+
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/lib/Data/Util.pm Sun Mar 10 13:41:30 2002
@@ -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 <[EMAIL PROTECTED]> using XS code by Nick Ing-Simmons.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>
+
+=cut
+
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/lib/Hash/Util.pm Sun Mar 10 13:41:35 2002
@@ -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 <[EMAIL PROTECTED]> 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;
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/t/Data.t Sun Mar 10 13:41:54 2002
@@ -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} );
--- /dev/null Mon Jan 28 02:17:54 2002
+++ ext/Data/Util/t/Hash.t Sun Mar 10 13:41:54 2002
@@ -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');
--- MANIFEST Sun Mar 10 15:07:45 2002
+++ MANIFEST Sun Mar 10 15:07:45 2002
@@ -127,6 +127,13 @@
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/Utils/Changes Data/Hash::Util, Change log
+ext/Data/Utils/Makefile.PL Data/Hash::Util, Makefile.PL
+ext/Data/Utils/Util.xs Data/Hash::Util, Data::Util XS code
+ext/Data/Utils/lib/Data/Util.pm Data/Hash::Util, Data::Util
+ext/Data/Utils/lib/Hash/Util.pm Data/Hash::Util, Hash::Util
+ext/Data/Utils/t/Data.t Data/Hash::Util, Data::Util test
+ext/Data/Utils/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
@@ -2170,7 +2177,6 @@
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
--
Michael G. Schwern <[EMAIL PROTECTED]> http://www.pobox.com/~schwern/
Perl Quality Assurance <[EMAIL PROTECTED]> Kwalitee Is Job One
Not king yet
