From 4628ab6baf6387cd8e945b09269268efb73cd878 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Tue, 19 Nov 2013 00:02:17 +0100 Subject: [PATCH] work in progress - separate restricted fetch from readonly behavior for hashes --- MANIFEST | 1 + dump.c | 1 + ext/Hash-Util/lib/Hash/Util.pm | 41 ++- ext/Hash-Util/t/Util.t | 22 +- ext/Hash-Util/t/unrestricted.t | 569 +++++++++++++++++++++++++++++++++ hv.c | 14 +- hv.h | 4 + scope.c | 12 +- sv.h | 7 +- universal.c | 38 +++ 10 files changed, 678 insertions(+), 31 deletions(-) create mode 100644 ext/Hash-Util/t/unrestricted.t diff --git a/MANIFEST b/MANIFEST index 2c7233a14c4..7c2c664d45a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3608,6 +3608,7 @@ ext/Hash-Util-FieldHash/t/12_hashwarn.t Adapted from t/op/hashwarn.t ext/Hash-Util/lib/Hash/Util.pm Hash::Util ext/Hash-Util/Makefile.PL Makefile for Hash::Util ext/Hash-Util/t/Util.t See if Hash::Util works +ext/Hash-Util/t/unrestricted.t See if Hash::Util unrestricted hashes work ext/Hash-Util/Util.xs XS bits of Hash::Util ext/I18N-Langinfo/Langinfo.pm I18N::Langinfo ext/I18N-Langinfo/Langinfo.xs I18N::Langinfo diff --git a/dump.c b/dump.c index 409b975e7c7..b4c9a59227a 100644 --- a/dump.c +++ b/dump.c @@ -1430,6 +1430,7 @@ const struct flag_to_name cv_flags_names[] = { }; const struct flag_to_name hv_flags_names[] = { + {SVphv_RESTRICTED, "RESTRICTED,"}, {SVphv_SHAREKEYS, "SHAREKEYS,"}, {SVphv_LAZYDEL, "LAZYDEL,"}, {SVphv_HASKFLAGS, "HASKFLAGS,"}, diff --git a/ext/Hash-Util/lib/Hash/Util.pm b/ext/Hash-Util/lib/Hash/Util.pm index 8ae25d14d97..ecab3c93e7c 100644 --- a/ext/Hash-Util/lib/Hash/Util.pm +++ b/ext/Hash-Util/lib/Hash/Util.pm @@ -165,6 +165,9 @@ Both routines return a reference to the hash operated on. sub lock_ref_keys { my($hash, @keys) = @_; + my $opts; + $opts= shift @keys + if @keys and ref $keys[0]; Internals::hv_clear_placeholders %$hash; if( @keys ) { @@ -178,6 +181,7 @@ sub lock_ref_keys { foreach my $k (@keys) { $hash->{$k} = undef unless exists $hash->{$k}; } + Internals::HvRESTRICTED %$hash, 1 unless $opts && $opts->{unrestricted}; Internals::SvREADONLY %$hash, 1; foreach my $k (@keys) { @@ -185,6 +189,7 @@ sub lock_ref_keys { } } else { + Internals::HvRESTRICTED %$hash, 1 unless $opts && $opts->{unrestricted}; Internals::SvREADONLY %$hash, 1; } @@ -195,6 +200,7 @@ sub unlock_ref_keys { my $hash = shift; Internals::SvREADONLY %$hash, 0; + Internals::HvRESTRICTED %$hash, 0; return $hash; } @@ -218,6 +224,10 @@ Returns a reference to %hash sub lock_ref_keys_plus { my ($hash,@keys) = @_; + my $opts; + $opts= shift @keys + if @keys and ref $keys[0]; + my @delete; Internals::hv_clear_placeholders(%$hash); foreach my $key (@keys) { @@ -226,6 +236,7 @@ sub lock_ref_keys_plus { push @delete,$key; } } + Internals::HvRESTRICTED %$hash, 1 unless $opts && $opts->{unrestricted}; Internals::SvREADONLY(%$hash,1); delete @{$hash}{@delete}; return $hash @@ -292,9 +303,10 @@ Returns a reference to the %hash. =cut sub lock_hashref { - my $hash = shift; + my ($hash, $opts) = @_; + $opts ||= {}; - lock_ref_keys($hash); + lock_ref_keys($hash, $opts); foreach my $value (values %$hash) { Internals::SvREADONLY($value,1); @@ -304,19 +316,20 @@ sub lock_hashref { } sub unlock_hashref { - my $hash = shift; + my ($hash, $opts) = @_; + $opts ||= {}; foreach my $value (values %$hash) { Internals::SvREADONLY($value, 0); } - unlock_ref_keys($hash); + unlock_ref_keys($hash, $opts); return $hash; } -sub lock_hash (\%) { lock_hashref(@_) } -sub unlock_hash (\%) { unlock_hashref(@_) } +sub lock_hash (\%;$) { lock_hashref(@_) } +sub unlock_hash (\%;$) { unlock_hashref(@_) } =item B @@ -343,13 +356,14 @@ Returns a reference to the %hash. =cut sub lock_hashref_recurse { - my $hash = shift; + my ($hash, $opts) = @_; + $opts ||= {}; - lock_ref_keys($hash); + lock_ref_keys($hash, $opts); foreach my $value (values %$hash) { my $type = reftype($value); if (defined($type) and $type eq 'HASH') { - lock_hashref_recurse($value); + lock_hashref_recurse($value, $opts); } Internals::SvREADONLY($value,1); } @@ -357,16 +371,17 @@ sub lock_hashref_recurse { } sub unlock_hashref_recurse { - my $hash = shift; + my ($hash, $opts) = @_; + $opts ||= {}; foreach my $value (values %$hash) { my $type = reftype($value); if (defined($type) and $type eq 'HASH') { - unlock_hashref_recurse($value); + unlock_hashref_recurse($value, $opts); } - Internals::SvREADONLY($value,1); + Internals::SvREADONLY($value,0); } - unlock_ref_keys($hash); + unlock_ref_keys($hash, $opts); return $hash; } diff --git a/ext/Hash-Util/t/Util.t b/ext/Hash-Util/t/Util.t index 2e9e3337e33..d37dc6403e0 100644 --- a/ext/Hash-Util/t/Util.t +++ b/ext/Hash-Util/t/Util.t @@ -47,7 +47,7 @@ foreach my $func (@Exported_Funcs) { 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 restricted hash/, +like( $@, qr/^Attempt to store disallowed key 'baz' in a readonly hash/, 'lock_keys()'); is( $hash{bar}, 23, '$hash{bar} == 23' ); ok( !exists $hash{baz},'!exists $hash{baz}' ); @@ -58,16 +58,16 @@ $hash{bar} = 69; is( $hash{bar}, 69 ,'$hash{bar} == 69'); eval { () = $hash{i_dont_exist} }; -like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/, +like( $@, qr/^Attempt to fetch disallowed key 'i_dont_exist' in a restricted hash/, 'Disallowed 1' ); lock_value(%hash, 'locked'); eval { print "# oops" if $hash{four} }; -like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/, +like( $@, qr/^Attempt to fetch disallowed key 'four' in a restricted hash/, 'Disallowed 2' ); eval { $hash{"\x{2323}"} = 3 }; -like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, +like( $@, qr/^Attempt to store disallowed key '(.*)' in a restricted hash/, 'wide hex key' ); eval { delete $hash{locked} }; @@ -104,7 +104,7 @@ is( $hash{locked}, 42, 'unlock_value' ); lock_keys(%hash); eval { %hash = ( wubble => 42 ) }; # we know this will bomb - like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' ); + like( $@, qr/^Attempt to store disallowed key 'wubble'/,'Disallowed 3' ); unlock_keys(%hash); } @@ -132,7 +132,7 @@ is( $hash{locked}, 42, 'unlock_value' ); $hash{foo} = 42; is( keys %hash, 1, '1 element in hash' ); eval { $hash{wibble} = 42 }; - like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, + like( $@, qr/^Attempt to store disallowed key 'wibble' in a restricted hash/, 'write threw error (locked)'); unlock_keys(%hash); @@ -150,7 +150,7 @@ is( $hash{locked}, 42, 'unlock_value' ); is( $@, '','No error 1' ); eval { $hash{wibble} = 23 }; - like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, + like( $@, qr/^Attempt to store disallowed key 'wibble' in a restricted hash/, 'locked "wibble"' ); } @@ -194,7 +194,7 @@ lock_keys(%ENV); eval { () = $ENV{I_DONT_EXIST} }; like( $@, - qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, + qr/^Attempt to fetch disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV' ); unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise @@ -223,11 +223,11 @@ unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise eval {$hash{zeroeth} = 0}; like ($@, - qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, + qr/^Attempt to store disallowed key 'zeroeth' in a restricted hash/, 'locked key never mentioned before should fail'); eval {$hash{first} = -1}; like ($@, - qr/^Attempt to access disallowed key 'first' in a restricted hash/, + qr/^Attempt to store disallowed key 'first' in a restricted hash/, 'previously locked place holders should also fail'); is (scalar keys %hash, 0, "and therefore there are no keys"); $hash{second} = 1; @@ -248,7 +248,7 @@ unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise eval {$hash{second} = -1}; like ($@, - qr/^Attempt to access disallowed key 'second' in a restricted hash/, + qr/^Attempt to store disallowed key 'second' in a restricted hash/, 'previously locked place holders should fail'); is ($hash{void}, undef, diff --git a/ext/Hash-Util/t/unrestricted.t b/ext/Hash-Util/t/unrestricted.t new file mode 100644 index 00000000000..397b228c34d --- /dev/null +++ b/ext/Hash-Util/t/unrestricted.t @@ -0,0 +1,569 @@ +#!/usr/bin/perl -Tw + +BEGIN { + if ($ENV{PERL_CORE}) { + require Config; import Config; + no warnings 'once'; + if ($Config{extensions} !~ /\bHash\/Util\b/) { + print "1..0 # Skip: Hash::Util was not built\n"; + exit 0; + } + } +} + +use strict; +use Test::More; +my @Exported_Funcs; +BEGIN { + @Exported_Funcs = qw( + fieldhash fieldhashes + + all_keys + lock_keys unlock_keys + lock_value unlock_value + lock_hash unlock_hash + lock_keys_plus + hash_locked hash_unlocked + hashref_locked hashref_unlocked + hidden_keys legal_keys + + lock_ref_keys unlock_ref_keys + lock_ref_value unlock_ref_value + lock_hashref unlock_hashref + lock_ref_keys_plus + hidden_ref_keys legal_ref_keys + + hash_seed hash_value bucket_stats bucket_info bucket_array + hv_store + lock_hash_recurse unlock_hash_recurse + ); + plan tests => 236 + @Exported_Funcs; + 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,{unrestricted=>1}); +eval { $hash{baz} = 99; }; +like( $@, qr/^Attempt to store disallowed key 'baz' in a readonly hash/, + 'lock_keys()'); +is( $hash{bar}, 23, '$hash{bar} == 23' ); +ok( !exists $hash{baz},'!exists $hash{baz}' ); + +delete $hash{bar}; +ok( !exists $hash{bar},'!exists $hash{bar}' ); +$hash{bar} = 69; +is( $hash{bar}, 69 ,'$hash{bar} == 69'); + +eval { () = $hash{i_dont_exist} }; +unlike( $@, qr/^Attempt to fetch disallowed key 'i_dont_exist' in a restricted hash/, + 'Disallowed 1' ); + +lock_value(%hash, {unrestricted=>1}, 'locked'); +eval { print "# oops" if $hash{four} }; +unlike( $@, qr/^Attempt to fetch disallowed key 'four' in a restricted hash/, + 'Disallowed 2' ); + +eval { $hash{"\x{2323}"} = 3 }; +like( $@, qr/^Attempt to store disallowed key '(.*)' in a restricted hash/, + 'wide hex key' ); + +eval { delete $hash{locked} }; +like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted 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', '$hash{locked} is yep' ); + +eval { delete $hash{I_dont_exist} }; +like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, + 'trying to delete a key that doesnt exist' ); + +ok( !exists $hash{I_dont_exist},'!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' ); + + +{ + my %hash = ( foo => 42, locked => 23 ); + + lock_keys(%hash,{unrestricted=>1}); + eval { %hash = ( wubble => 42 ) }; # we know this will bomb + like( $@, qr/^Attempt to store disallowed key 'wubble'/,'Disallowed 3' ); + unlock_keys(%hash); +} + +{ + my %hash = (KEY => 'val', RO => 'val'); + lock_keys(%hash,{unrestricted=>1}); + lock_value(%hash, 'RO'); + + eval { %hash = (KEY => 1) }; + like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/, + 'attempt to delete readonly key from restricted hash' ); +} + +{ + my %hash = (KEY => 1, RO => 2); + lock_keys(%hash, {unrestricted=>1}); + eval { %hash = (KEY => 1, RO => 2) }; + is( $@, '', 'No error message, as expected'); +} + +{ + my %hash = (); + lock_keys(%hash, {unrestricted=>1}, qw(foo bar)); + is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' ); + $hash{foo} = 42; + is( keys %hash, 1, '1 element in hash' ); + eval { $hash{wibble} = 42 }; + like( $@, qr/^Attempt to store disallowed key 'wibble' in a restricted hash/, + 'write threw error (locked)'); + + unlock_keys(%hash); + eval { $hash{wibble} = 23; }; + is( $@, '', 'unlock_keys' ); +} + +{ + my %hash = (foo => 42, bar => undef, baz => 0); + lock_keys(%hash, {unrestricted=>1}, 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 },'is_deeply' ); + + eval { $hash{up} = 42; }; + is( $@, '','No error 1' ); + + eval { $hash{wibble} = 23 }; + like( $@, qr/^Attempt to store disallowed key 'wibble' in a restricted hash/, + 'locked "wibble"' ); +} + +{ + my %hash = (foo => 42, bar => undef); + eval { lock_keys(%hash, {restricted=>1}, qw(foo baz)); }; + like( $@, qr/^Hash has key 'bar' which is not in the new key set/, + 'carp test' ); +} + +{ + my %hash = (foo => 42, bar => 23); + lock_hash( %hash, {restricted=>1}, ); + ok( hashref_locked( \%hash ), 'hashref_locked' ); + ok( hash_locked( %hash ), 'hash_locked' ); + + ok( Internals::SvREADONLY(%hash),'Was locked %hash' ); + ok( Internals::SvREADONLY($hash{foo}),'Was locked $hash{foo}' ); + ok( Internals::SvREADONLY($hash{bar}),'Was locked $hash{bar}' ); + + unlock_hash ( %hash ); + ok( hashref_unlocked( { %hash } ), 'hashref_unlocked' ); + ok( hash_unlocked( %hash ), 'hash_unlocked' ); + + ok( !Internals::SvREADONLY(%hash),'Was unlocked %hash' ); + ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' ); + ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' ); +} + +{ + my %hash = (foo => 42, bar => 23); + ok( ! hashref_locked( { %hash } ), 'hashref_locked negated' ); + ok( ! hash_locked( %hash ), 'hash_locked negated' ); + + lock_hash( %hash, {unrestricted=>1}, ); + ok( ! hashref_unlocked( \%hash ), 'hashref_unlocked negated' ); + ok( ! hash_unlocked( %hash ), 'hash_unlocked negated' ); +} + +lock_keys(%ENV, {unrestricted=>1},); +eval { () = $ENV{I_DONT_EXIST} }; +like( + $@, + qr/^Attempt to fetch disallowed key 'I_DONT_EXIST' in a restricted hash/, + 'locked %ENV' +); +unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise + +{ + my %hash; + + lock_keys(%hash, {unrestricted=>1}, 'first'); + + is (scalar keys %hash, 0, "place holder isn't a key"); + $hash{first} = 1; + is (scalar keys %hash, 1, "we now have a key"); + delete $hash{first}; + is (scalar keys %hash, 0, "now no key"); + + unlock_keys(%hash); + + $hash{interregnum} = 1.5; + is (scalar keys %hash, 1, "key again"); + delete $hash{interregnum}; + is (scalar keys %hash, 0, "no key again"); + + lock_keys(%hash, {unrestricted=>1}, 'second'); + + is (scalar keys %hash, 0, "place holder isn't a key"); + + eval {$hash{zeroeth} = 0}; + like ($@, + qr/^Attempt to store disallowed key 'zeroeth' in a restricted hash/, + 'locked key never mentioned before should fail'); + eval {$hash{first} = -1}; + like ($@, + qr/^Attempt to store disallowed key 'first' in a restricted hash/, + 'previously locked place holders should also fail'); + is (scalar keys %hash, 0, "and therefore there are no keys"); + $hash{second} = 1; + is (scalar keys %hash, 1, "we now have just one key"); + delete $hash{second}; + is (scalar keys %hash, 0, "back to zero"); + + unlock_keys(%hash); # We have deliberately left a placeholder. + + $hash{void} = undef; + $hash{nowt} = undef; + + is (scalar keys %hash, 2, "two keys, values both undef"); + + lock_keys(%hash,{unrestricted=>1}); + + is (scalar keys %hash, 2, "still two keys after locking"); + + eval {$hash{second} = -1}; + like ($@, + qr/^Attempt to store disallowed key 'second' in a restricted hash/, + 'previously locked place holders should fail'); + + is ($hash{void}, undef, + "undef values should not be misunderstood as placeholders"); + is ($hash{nowt}, undef, + "undef values should not be misunderstood as placeholders (again)"); +} + +{ + # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant + # bug whereby hash iterators could lose hash keys (and values, as the code + # is common) for restricted hashes. + + my @keys = qw(small medium large); + + # There should be no difference whether it is restricted or not + foreach my $lock (0, 1) { + # Try setting all combinations of the 3 keys + foreach my $usekeys (0..7) { + my @usekeys; + for my $bits (0,1,2) { + push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); + } + my %clean = map {$_ => length $_} @usekeys; + my %target; + lock_keys ( %target,{unrestricted=>1}, @keys ) if $lock; + + while (my ($k, $v) = each %clean) { + $target{$k} = $v; + } + + my $message + = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; + + is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); + is (scalar values %target, scalar values %clean, + "scalar values for $message"); + # Yes. All these sorts are necessary. Even for "identical hashes" + # Because the data dependency of the test involves two of the strings + # colliding on the same bucket, so the iterator order (output of keys, + # values, each) depends on the addition order in the hash. And locking + # the keys of the hash involves behind the scenes key additions. + is_deeply( [sort keys %target] , [sort keys %clean], + "list keys for $message"); + is_deeply( [sort values %target] , [sort values %clean], + "list values for $message"); + + is_deeply( [sort %target] , [sort %clean], + "hash in list context for $message"); + + my (@clean, @target); + while (my ($k, $v) = each %clean) { + push @clean, $k, $v; + } + while (my ($k, $v) = each %target) { + push @target, $k, $v; + } + + is_deeply( [sort @target] , [sort @clean], + "iterating with each for $message"); + } + } +} + +# Check clear works on locked empty hashes - SEGVs on 5.8.2. +{ + my %hash; + lock_hash(%hash, {unrestricted=>1}); + %hash = (); + ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); +} +{ + my %hash; + lock_keys(%hash, {unrestricted=>1}); + %hash = (); + ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); +} + +# Copy-on-write scalars should not be deletable after lock_hash; +{ + my %hash = (key=>__PACKAGE__); + lock_hash(%hash, {unrestricted=>1}); + eval { delete $hash{key} }; + like $@, qr/^Attempt to delete readonly key /, + 'COW scalars are not exempt from lock_hash (delete)'; + eval { %hash = () }; + like $@, qr/^Attempt to delete readonly key /, + 'COW scalars are not exempt from lock_hash (clear)'; +} + +my $hash_seed = hash_seed(); +ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); + +{ + package Minder; + my $counter; + sub DESTROY { + --$counter; + } + sub new { + ++$counter; + bless [], __PACKAGE__; + } + package main; + + for my $state ('', 'locked') { + my $a = Minder->new(); + is ($counter, 1, "There is 1 object $state"); + my %hash; + $hash{a} = $a; + is ($counter, 1, "There is still 1 object $state"); + + lock_keys(%hash, {unrestricted=>1}) if $state; + + is ($counter, 1, "There is still 1 object $state"); + undef $a; + is ($counter, 1, "Still 1 object $state"); + delete $hash{a}; + is ($counter, 0, "0 objects when hash key is deleted $state"); + $hash{a} = undef; + is ($counter, 0, "Still 0 objects $state"); + %hash = (); + is ($counter, 0, "0 objects after clear $state"); + } +} +{ + my %hash = map {$_,$_} qw(fwiffffff foosht teeoo); + lock_keys(%hash, {unrestricted=>1}); + delete $hash{fwiffffff}; + is (scalar keys %hash, 2,"Count of keys after delete on locked hash"); + unlock_keys(%hash); + is (scalar keys %hash, 2,"Count of keys after unlock"); + + my ($first, $value) = each %hash; + is ($hash{$first}, $value, "Key has the expected value before the lock"); + lock_keys(%hash, {unrestricted=>1}); + is ($hash{$first}, $value, "Key has the expected value after the lock"); + + my ($second, $v2) = each %hash; + + is ($hash{$first}, $value, "Still correct after iterator advances"); + is ($hash{$second}, $v2, "Other key has the expected value"); +} +{ + my $x='foo'; + my %test; + hv_store(%test,'x',$x); + is($test{x},'foo','hv_store() stored'); + $test{x}='bar'; + is($x,'bar','hv_store() aliased'); + is($test{x},'bar','hv_store() aliased and stored'); +} + +{ + my %hash=map { $_ => 1 } qw( a b c d e f); + delete $hash{c}; + lock_keys(%hash, {unrestricted=>1}); + ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 1'); + delete @hash{qw(b e)}; + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + #warn "@legal\n@keys\n"; + is("@hidden","b e",'lock_keys @hidden DDS/t'); + is("@legal","a b d e f",'lock_keys @legal DDS/t'); + is("@keys","a d f",'lock_keys @keys DDS/t'); +} +{ + my %hash=(0..9); + lock_keys(%hash, {unrestricted=>1}); + ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 2'); + Hash::Util::unlock_keys(%hash); + ok(!Internals::SvREADONLY(%hash),'unlock_keys DDS/t 2'); +} +{ + my %hash=(0..9); + lock_keys(%hash, {unrestricted=>1},keys(%hash),'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3'); + is("@keys","0 2 4 6 8",'lock_keys() @keys'); +} +{ + my %hash=map { $_ => 1 } qw( a b c d e f); + delete $hash{c}; + lock_ref_keys(\%hash, {unrestricted=>1}); + ok(Internals::SvREADONLY(%hash),'lock_ref_keys DDS/t'); + delete @hash{qw(b e)}; + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + #warn "@legal\n@keys\n"; + is("@hidden","b e",'lock_ref_keys @hidden DDS/t 1'); + is("@legal","a b d e f",'lock_ref_keys @legal DDS/t 1'); + is("@keys","a d f",'lock_ref_keys @keys DDS/t 1'); +} +{ + my %hash=(0..9); + lock_ref_keys(\%hash, {unrestricted=>1},keys %hash,'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2'); + is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2'); +} +{ + my %hash=(0..9); + lock_ref_keys_plus(\%hash, {unrestricted=>1},'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t'); + is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t'); +} +{ + my %hash=(0..9, 'a' => 'alpha'); + lock_ref_keys_plus(\%hash, {unrestricted=>1},'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args overlap'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","b c d e f",'lock_ref_keys_plus() @hidden overlap'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal overlap'); + is("@keys","0 2 4 6 8 a",'lock_ref_keys_plus() @keys overlap'); +} +{ + my %hash=(0..9); + lock_keys_plus(%hash, {unrestricted=>1},'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3'); + is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3'); +} +{ + my %hash=(0..9, 'a' => 'alpha'); + lock_keys_plus(%hash, {unrestricted=>1},'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_keys_plus args overlap non-ref'); + my @hidden=sort(hidden_keys(%hash)); + my @legal=sort(legal_keys(%hash)); + my @keys=sort(keys(%hash)); + is("@hidden","b c d e f",'lock_keys_plus() @hidden overlap non-ref'); + is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal overlap non-ref'); + is("@keys","0 2 4 6 8 a",'lock_keys_plus() @keys overlap non-ref'); +} + +{ + my %hash = ('a'..'f'); + my @keys = (); + my @ph = (); + my @lock = ('a', 'c', 'e', 'g'); + lock_keys(%hash, {unrestricted=>1}, @lock); + my $ref = all_keys(%hash, @keys, @ph); + my @crrack = sort(@keys); + my @ooooff = qw(a c e); + my @bam = qw(g); + + ok(ref $ref eq ref \%hash && $ref == \%hash, + "all_keys() - \$ref is a reference to \%hash"); + is_deeply(\@crrack, \@ooooff, "Keys are what they should be"); + is_deeply(\@ph, \@bam, "Placeholders in place"); +} + +{ + my %hash = ( + a => 'alpha', + b => [ qw( beta gamma delta ) ], + c => [ 'epsilon', { zeta => 'eta' }, ], + d => { theta => 'iota' }, + ); + lock_hash_recurse(%hash, {unrestricted=>1}); + ok( hash_locked(%hash), + "lock_hash_recurse(): top-level hash locked" ); + ok( hash_locked(%{$hash{d}}), + "lock_hash_recurse(): element which is hashref locked" ); + ok( ! hash_locked(%{$hash{c}[1]}), + "lock_hash_recurse(): element which is hashref in array ref not locked" ); + + unlock_hash_recurse(%hash); + ok( hash_unlocked(%hash), + "unlock_hash_recurse(): top-level hash unlocked" ); + ok( hash_unlocked(%{$hash{d}}), + "unlock_hash_recurse(): element which is hashref unlocked" ); + ok( hash_unlocked(%{$hash{c}[1]}), + "unlock_hash_recurse(): element which is hashref in array ref not locked" ); +} + +{ + my $h1= hash_value("foo"); + my $h2= hash_value("bar"); + is( $h1, hash_value("foo") ); + is( $h2, hash_value("bar") ); +} +{ + my @info1= bucket_info({}); + my @info2= bucket_info({1..10}); + my @stats1= bucket_stats({}); + my @stats2= bucket_stats({1..10}); + my $array1= bucket_array({}); + my $array2= bucket_array({1..10}); + is("@info1","0 8 0"); + is("@info2[0,1]","5 8"); + is("@stats1","0 8 0"); + is("@stats2[0,1]","5 8"); + my @keys1= sort map { ref $_ ? @$_ : () } @$array1; + my @keys2= sort map { ref $_ ? @$_ : () } @$array2; + is("@keys1",""); + is("@keys2","1 3 5 7 9"); +} diff --git a/hv.c b/hv.c index 45ee0a4d936..a5aabc7a007 100644 --- a/hv.c +++ b/hv.c @@ -728,9 +728,17 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { - hv_notallowed(flags, key, klen, - "Attempt to access disallowed key '%"SVf"' in" - " a restricted hash"); + if (action & (HV_FETCH_ISSTORE|HV_FETCH_LVALUE)) { + hv_notallowed(flags, key, klen, + "Attempt to store disallowed key '%"SVf"' in" + " a readonly hash"); + } + else + if ( HvRESTRICTED(hv) ) { + hv_notallowed(flags, key, klen, + "Attempt to fetch disallowed key '%"SVf"' in" + " a restricted hash"); + } } if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { /* Not doing some form of store, so return failure. */ diff --git a/hv.h b/hv.h index b8f496c60d2..47844da00d1 100644 --- a/hv.h +++ b/hv.h @@ -318,6 +318,10 @@ C. #define HvPLACEHOLDERS_get(hv) (SvMAGIC(hv) ? Perl_hv_placeholders_get(aTHX_ (const HV *)hv) : 0) #define HvPLACEHOLDERS_set(hv,p) Perl_hv_placeholders_set(aTHX_ MUTABLE_HV(hv), p) +#define HvRESTRICTED(hv) (SvFLAGS(hv) & SVphv_RESTRICTED) +#define HvRESTRICTED_on(hv) (SvFLAGS(hv) |= SVphv_RESTRICTED) +#define HvRESTRICTED_off(hv) (SvFLAGS(hv) &= ~SVphv_RESTRICTED) + #define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS) #define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS) #define HvSHAREKEYS_off(hv) (SvFLAGS(hv) &= ~SVphv_SHAREKEYS) diff --git a/scope.c b/scope.c index 38eea2f9282..79cb83a7109 100644 --- a/scope.c +++ b/scope.c @@ -1043,11 +1043,17 @@ Perl_leave_scope(pTHX_ I32 base) * scope, we want to remove the readonlyness so that it can * go out of scope quietly */ - if (SvPADMY(sv) && !SvFAKE(sv)) - SvREADONLY_off(sv); - if (SvTYPE(sv) == SVt_PVHV) + if (SvTYPE(sv) == SVt_PVHV) { + if (SvPADMY(sv)) { + SvREADONLY_off(sv); + HvRESTRICTED_off(sv); + } Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + } else if (SvPADMY(sv) && !SvFAKE(sv)) { + SvREADONLY_off(sv); + } + if (SvMAGICAL(sv)) { sv_unmagic(sv, PERL_MAGIC_backref); diff --git a/sv.h b/sv.h index bb9e6b03dd2..b97b80c1a64 100644 --- a/sv.h +++ b/sv.h @@ -383,7 +383,12 @@ perform the upgrade if necessary. See C. [CvEVAL(cv), CvSPECIAL(cv)] 3: On a pad name SV, that slot in the frame AV is a REFCNT'ed reference - to a lexical from "outside". */ + to a lexical from "outside". + 4: On a PVHV, READONLY hash is RESTRICTED, + fetches for missing keys will die. + */ +#define SVphv_RESTRICTED SVf_FAKE + #define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this means that a hv_aux struct is present after the main array */ diff --git a/universal.c b/universal.c index 969acbd03ac..508a33dd6a6 100644 --- a/universal.c +++ b/universal.c @@ -914,6 +914,43 @@ XS(XS_utf8_unicode_to_native) XSRETURN(1); } +XS(XS_Internals_HvRESTRICTED) /* This is dangerous stuff. */ +{ + dVAR; + dXSARGS; + SV * const svz = ST(0); + SV * sv; + PERL_UNUSED_ARG(cv); + + /* [perl #77776] - called as &foo() not foo() */ + if (!SvROK(svz)) + croak_xs_usage(cv, "HASH[, ON]"); + + sv = SvRV(svz); + if (SvTYPE(sv) != SVt_PVHV) { + croak_xs_usage(cv, "HASH[, ON]"); + } + + if (items == 1) { + if (HvRESTRICTED(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + else if (items == 2) { + if (SvTRUE(ST(1))) { + HvRESTRICTED_on(sv); + XSRETURN_YES; + } + else { + /* I hope you really know what you are doing. */ + HvRESTRICTED_off(sv); + XSRETURN_NO; + } + } + XSRETURN_UNDEF; /* Can't happen. */ +} + XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { dVAR; @@ -1398,6 +1435,7 @@ static const struct xsub_details details[] = { {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, + {"Internals::HvRESTRICTED", XS_Internals_HvRESTRICTED, "\\%;$"}, {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},