From 2956957731badfc3e16c029c1f22e4098fb8c46a Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Tue, 12 Mar 2002 15:41:23 +0000 Subject: Move the readonly interface back to universal.c, (new name: Internals::SvREADONLY), remove Data::Util, move Hash::Util to lib, also introduce refcnt interface (Internals::SvREFCNT). Make both the new interfaces to be more sane so that if they set the value, they return the new value, not the old one. p4raw-id: //depot/perl@15201 --- MANIFEST | 12 +-- ext/B/t/stash.t | 2 +- ext/Data/Util/Changes | 27 ------ ext/Data/Util/Makefile.PL | 53 ------------ ext/Data/Util/Util.xs | 29 ------- ext/Data/Util/lib/Data/Util.pm | 73 ---------------- ext/Data/Util/lib/Hash/Util.pm | 191 ----------------------------------------- ext/Data/Util/t/Data.t | 42 --------- ext/Data/Util/t/Hash.t | 171 ------------------------------------ lib/Hash/Util.pm | 190 ++++++++++++++++++++++++++++++++++++++++ lib/Hash/Util.t | 170 ++++++++++++++++++++++++++++++++++++ lib/Internals.t | 51 +++++++++++ universal.c | 40 +++++++++ 13 files changed, 456 insertions(+), 595 deletions(-) delete mode 100644 ext/Data/Util/Changes delete mode 100644 ext/Data/Util/Makefile.PL delete mode 100644 ext/Data/Util/Util.xs delete mode 100644 ext/Data/Util/lib/Data/Util.pm delete mode 100644 ext/Data/Util/lib/Hash/Util.pm delete mode 100644 ext/Data/Util/t/Data.t delete mode 100644 ext/Data/Util/t/Hash.t create mode 100644 lib/Hash/Util.pm create mode 100644 lib/Hash/Util.t create mode 100644 lib/Internals.t diff --git a/MANIFEST b/MANIFEST index 5ba6957153..3649958deb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -127,13 +127,6 @@ 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 @@ -1087,6 +1080,8 @@ lib/Getopt/Std.t See if Getopt::Std and Getopt::Long work lib/getopts.pl Perl library supporting option parsing lib/h2ph.t See if h2ph works like it should lib/h2xs.t See if h2xs produces expected lists of files +lib/Hash/Util.pm Hash::Util +lib/Hash/Util.t See if Hash::Util works lib/hostname.pl Old hostname code lib/I18N/Collate.pm Routines to do strxfrm-based collation lib/I18N/Collate.t See if I18N::Collate works @@ -1100,6 +1095,7 @@ lib/if.t Tests for "use if" lib/importenv.pl Perl routine to get environment into variables lib/integer.pm For "use integer" lib/integer.t For "use integer" testing +lib/Internals.t For Internals::* testing lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open2.t See if IPC::Open2 works lib/IPC/Open3.pm Open a three-ended pipe! @@ -2064,8 +2060,8 @@ Porting/checkVERSION.pl Check whether we have $VERSIONs Porting/config.sh Sample config.sh Porting/config_H Sample config.h Porting/Contract Social contract for contributed modules in Perl core -Porting/findvars Find occurrences of words Porting/findrfuncs Find reentrant variants of functions used in an executable +Porting/findvars Find occurrences of words Porting/fixCORE Find and fix modules that generate warnings Porting/fixvars Find undeclared variables with C compiler and fix em Porting/genlog Generate formatted changelogs by querying p4d diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t index 9916521414..9448425283 100755 --- a/ext/B/t/stash.t +++ b/ext/B/t/stash.t @@ -66,7 +66,7 @@ print "# got = @got\n"; $got = "@got"; -my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy main utf8 warnings"; +my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals main utf8 warnings"; { no strict 'vars'; diff --git a/ext/Data/Util/Changes b/ext/Data/Util/Changes deleted file mode 100644 index f877d08678..0000000000 --- a/ext/Data/Util/Changes +++ /dev/null @@ -1,27 +0,0 @@ -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 deleted file mode 100644 index ef6bc3c3ab..0000000000 --- a/ext/Data/Util/Makefile.PL +++ /dev/null @@ -1,53 +0,0 @@ -# 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 deleted file mode 100644 index 6d246ddf51..0000000000 --- a/ext/Data/Util/Util.xs +++ /dev/null @@ -1,29 +0,0 @@ -#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 deleted file mode 100644 index 26e2993a9b..0000000000 --- a/ext/Data/Util/lib/Data/Util.pm +++ /dev/null @@ -1,73 +0,0 @@ -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 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 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 - -The exact behavior exhibited by a piece of DATA when sv_readonly is -set depends on what type of data it is. B Look for specific functions in Scalar::Util, -List::Util and Hash::Util for making those respective types readonly. - -=head1 AUTHOR - -Michael G Schwern using XS code by Nick Ing-Simmons. - -=head1 SEE ALSO - -L, L, L - -=cut - diff --git a/ext/Data/Util/lib/Hash/Util.pm b/ext/Data/Util/lib/Hash/Util.pm deleted file mode 100644 index c54fbdc0d1..0000000000 --- a/ext/Data/Util/lib/Hash/Util.pm +++ /dev/null @@ -1,191 +0,0 @@ -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 contains special functions for manipulating hashes that -don't really warrant a keyword. - -By default C 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 - -=item B - - 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 on top of code by Nick -Ing-Simmons and Jeffrey Friedl. - -=head1 SEE ALSO - -L, L, L - -=cut - -1; diff --git a/ext/Data/Util/t/Data.t b/ext/Data/Util/t/Data.t deleted file mode 100644 index 6198c3a9f3..0000000000 --- a/ext/Data/Util/t/Data.t +++ /dev/null @@ -1,42 +0,0 @@ -#!/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 deleted file mode 100644 index b1f9e79304..0000000000 --- a/ext/Data/Util/t/Hash.t +++ /dev/null @@ -1,171 +0,0 @@ -#!/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/lib/Hash/Util.pm b/lib/Hash/Util.pm new file mode 100644 index 0000000000..f6fed97ab4 --- /dev/null +++ b/lib/Hash/Util.pm @@ -0,0 +1,190 @@ +package Hash::Util; + +require 5.007003; +use strict; +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 contains special functions for manipulating hashes that +don't really warrant a keyword. + +By default C 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}; + } + Internals::SvREADONLY %$hash, 1; + + foreach my $k (@keys) { + delete $hash->{$k} unless $original_keys{$k}; + } + } + else { + Internals::SvREADONLY %$hash, 1; + } + + return undef; +} + +sub unlock_keys (\%) { + my($hash) = shift; + + Internals::SvREADONLY %$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 Internals::SvREADONLY %$hash; + Internals::SvREADONLY $hash->{$key}, 1; +} + +sub unlock_value (\%$) { + my($hash, $key) = @_; + Internals::SvREADONLY $hash->{$key}, 0; +} + + +=item B + +=item B + + 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 on top of code by Nick +Ing-Simmons and Jeffrey Friedl. + +=head1 SEE ALSO + +L, L, L + +=cut + +1; diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t new file mode 100644 index 0000000000..0fe3128172 --- /dev/null +++ b/lib/Hash/Util.t @@ -0,0 +1,170 @@ +#!/usr/bin/perl -Tw + +BEGIN { + if( $ENV{PERL_CORE} ) { + @INC = '../lib'; + chdir 't'; + } +} +use Test::More tests => 45; + +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( Internals::SvREADONLY(%hash) ); + ok( Internals::SvREADONLY($hash{foo}) ); + ok( Internals::SvREADONLY($hash{bar}) ); + + unlock_hash ( %hash ); + + ok( !Internals::SvREADONLY(%hash) ); + ok( !Internals::SvREADONLY($hash{foo}) ); + ok( !Internals::SvREADONLY($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/lib/Internals.t b/lib/Internals.t new file mode 100644 index 0000000000..1f514fd344 --- /dev/null +++ b/lib/Internals.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl -Tw + +BEGIN { + if( $ENV{PERL_CORE} ) { + @INC = '../lib'; + chdir 't'; + } +} + +use Test::More tests => 29; + +my $foo; + +ok( !Internals::SvREADONLY $foo ); +ok( Internals::SvREADONLY $foo, 1 ); +ok( Internals::SvREADONLY $foo ); +ok( !Internals::SvREADONLY $foo, 0 ); +ok( !Internals::SvREADONLY $foo ); + +ok( !Internals::SvREADONLY @foo ); +ok( Internals::SvREADONLY @foo, 1 ); +ok( Internals::SvREADONLY @foo ); +ok( !Internals::SvREADONLY @foo, 0 ); +ok( !Internals::SvREADONLY @foo ); + +ok( !Internals::SvREADONLY $foo[2] ); +ok( Internals::SvREADONLY $foo[2], 1 ); +ok( Internals::SvREADONLY $foo[2] ); +ok( !Internals::SvREADONLY $foo[2], 0 ); +ok( !Internals::SvREADONLY $foo[2] ); + +ok( !Internals::SvREADONLY %foo ); +ok( Internals::SvREADONLY %foo, 1 ); +ok( Internals::SvREADONLY %foo ); +ok( !Internals::SvREADONLY %foo, 0 ); +ok( !Internals::SvREADONLY %foo ); + +ok( !Internals::SvREADONLY $foo{foo} ); +ok( Internals::SvREADONLY $foo{foo}, 1 ); +ok( Internals::SvREADONLY $foo{foo} ); +ok( !Internals::SvREADONLY $foo{foo}, 0 ); +ok( !Internals::SvREADONLY $foo{foo} ); + +is( Internals::SvREFCNT($foo), 1 ); +{ + my $bar = \$foo; + is( Internals::SvREFCNT($foo), 2 ); + is( Internals::SvREFCNT($bar), 1 ); +} +is( Internals::SvREFCNT($foo), 1 ); + diff --git a/universal.c b/universal.c index ae12e27984..16000f723d 100644 --- a/universal.c +++ b/universal.c @@ -167,6 +167,8 @@ XS(XS_utf8_upgrade); XS(XS_utf8_downgrade); XS(XS_utf8_unicode_to_native); XS(XS_utf8_native_to_unicode); +XS(XS_Internals_SvREADONLY); +XS(XS_Internals_SvREFCNT); void Perl_boot_core_UNIVERSAL(pTHX) @@ -183,6 +185,8 @@ 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("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); + newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); } @@ -458,3 +462,39 @@ XS(XS_utf8_unicode_to_native) XSRETURN(1); } +XS(XS_Internals_SvREADONLY) +{ + dXSARGS; + SV *sv = SvRV(ST(0)); + if (items == 1) { + if (SvREADONLY(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + else if (items == 2) { + if (SvTRUE(ST(1))) { + SvREADONLY_on(sv); + XSRETURN_YES; + } + else { + SvREADONLY_off(sv); + XSRETURN_NO; + } + } + XSRETURN_UNDEF; +} + +XS(XS_Internals_SvREFCNT) +{ + dXSARGS; + SV *sv = SvRV(ST(0)); + if (items == 1) + XSRETURN_IV(SvREFCNT(sv) - 1); /* minus the SvRV above */ + else if (items == 2) { + SvREFCNT(sv) = SvIV(ST(1)); + XSRETURN_IV(SvREFCNT(sv)); + } + XSRETURN_UNDEF; +} + -- cgit v1.2.1