diff options
| -rw-r--r-- | MANIFEST | 8 | ||||
| -rw-r--r-- | ext/Data/Util/Changes | 27 | ||||
| -rw-r--r-- | ext/Data/Util/Makefile.PL | 53 | ||||
| -rw-r--r-- | ext/Data/Util/Util.xs | 29 | ||||
| -rw-r--r-- | ext/Data/Util/lib/Data/Util.pm | 73 | ||||
| -rw-r--r-- | ext/Data/Util/lib/Hash/Util.pm | 191 | ||||
| -rw-r--r-- | ext/Data/Util/t/Data.t | 42 | ||||
| -rw-r--r-- | ext/Data/Util/t/Hash.t | 171 | ||||
| -rw-r--r-- | hv.c | 41 | ||||
| -rw-r--r-- | lib/File/Find/t/find.t | 4 | ||||
| -rw-r--r-- | lib/File/Find/t/taint.t | 8 | ||||
| -rw-r--r-- | pod/perldiag.pod | 24 | ||||
| -rw-r--r-- | pod/perltodo.pod | 10 | ||||
| -rw-r--r-- | t/lib/access.t | 82 | ||||
| -rw-r--r-- | universal.c | 21 |
15 files changed, 659 insertions, 125 deletions
@@ -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'); @@ -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; -} - |