From e4143958270da68a12d74112f1c5115cbdf3f85e Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Tue, 19 Nov 2013 00:02:17 +0100 Subject: [PATCH] HvRESTRICTED: separate restricted fetch from readonly behavior for hashes [cperl #57] --- MANIFEST | 1 + dump.c | 1 + ext/Hash-Util/lib/Hash/Util.pm | 39 ++- ext/Hash-Util/t/Util.t | 22 +- ext/Hash-Util/t/unrestricted.t | 607 +++++++++++++++++++++++++++++++++ hv.c | 49 ++- hv.h | 4 + pad.c | 6 +- scope.c | 27 +- sv.h | 6 +- universal.c | 39 +++ 11 files changed, 750 insertions(+), 51 deletions(-) create mode 100644 ext/Hash-Util/t/unrestricted.t diff --git a/MANIFEST b/MANIFEST index ac5ad2f04e3..29f9a7b0f7e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4145,6 +4145,7 @@ ext/Hash-Util/Changes Change history of Hash::Util ext/Hash-Util/lib/Hash/Util.pm Hash::Util ext/Hash-Util/Makefile.PL Makefile for Hash::Util ext/Hash-Util/t/builtin.t See if Hash::Util works +ext/Hash-Util/t/unrestricted.t See if Hash::Util works ext/Hash-Util/t/Util.t See if Hash::Util works ext/Hash-Util/Util.xs XS bits of Hash::Util ext/Hash-Util-FieldHash/Changes Changes for Hash::Util::FieldHash diff --git a/dump.c b/dump.c index 3e384c770ad..dd6a12b5029 100644 --- a/dump.c +++ b/dump.c @@ -2093,6 +2093,7 @@ const struct flag_to_name second_sv_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 59ce80c1f39..e5c8c0cc63e 100644 --- a/ext/Hash-Util/lib/Hash/Util.pm +++ b/ext/Hash-Util/lib/Hash/Util.pm @@ -177,6 +177,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]; _clear_placeholders(%$hash); if( @keys ) { @@ -190,6 +193,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) { @@ -197,6 +201,7 @@ sub lock_ref_keys { } } else { + Internals::HvRESTRICTED %$hash, 1 unless $opts && $opts->{unrestricted}; Internals::SvREADONLY %$hash, 1; } @@ -207,6 +212,7 @@ sub unlock_ref_keys { my $hash = shift; Internals::SvREADONLY %$hash, 0; + Internals::HvRESTRICTED %$hash, 0; return $hash; } @@ -243,6 +249,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; _clear_placeholders(%$hash); foreach my $key (@keys) { @@ -251,6 +261,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 @@ -317,9 +328,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); @@ -329,19 +341,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 @@ -368,13 +381,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); } @@ -382,16 +396,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,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 4a12fd1764f..3ae194da275 100644 --- a/ext/Hash-Util/t/Util.t +++ b/ext/Hash-Util/t/Util.t @@ -56,7 +56,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}' ); @@ -67,16 +67,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} }; @@ -113,7 +113,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); } @@ -141,7 +141,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); @@ -159,7 +159,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"' ); } @@ -203,7 +203,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 @@ -232,11 +232,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; @@ -257,7 +257,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..6ed3d675120 --- /dev/null +++ b/ext/Hash-Util/t/unrestricted.t @@ -0,0 +1,607 @@ +#!/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} }; +like( $@, 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} }; +like( $@, 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, 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, {unrestricted=>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 numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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 numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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,'a'..'f'); + ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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 numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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 numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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 numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first 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"); +} + +{ + # lock_hash_recurse / unlock_hash_recurse + 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" ); + { + local $@; + eval { $hash{d} = { theta => 'kappa' }; }; + ok(! $@, "No error; can assign to unlocked hash") + or diag($@); + } + ok( hash_unlocked(%{$hash{c}[1]}), + "unlock_hash_recurse(): element which is hashref in array ref not locked" ); +} + +{ + # lock_hashref_recurse / unlock_hashref_recurse + my %hash = ( + a => 'alpha', + b => [ qw( beta gamma delta ) ], + c => [ 'epsilon', { zeta => 'eta' }, ], + d => { theta => 'iota' }, + ); + Hash::Util::lock_hashref_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" ); + + Hash::Util::unlock_hashref_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" ); + { + local $@; + eval { $hash{d} = { theta => 'kappa' }; }; + ok(! $@, "No error; can assign to unlocked hash") + or diag($@); + } + 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 1282550adcb..ec1c7e7fde7 100644 --- a/hv.c +++ b/hv.c @@ -804,21 +804,40 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen, #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { - /* If the hash has a name report it also */ HEK *const name = HvNAME_HEK(hv); - if (name) { - /* But allow DESTROY calls in restricted coretypes */ - if ( strNEc(key, "DESTROY") && strNEc(key, "AUTOLOAD") ) { - SV *msg = newSVpvs_flags("Attempt to access disallowed key '%" SVf "' in" - " the restricted hash '%%", SVs_TEMP); - sv_cathek(msg, name); - sv_catpvs(msg, "::'"); - hv_notallowed(flags, key, klen, SvPVX(msg)); + if (action & (HV_FETCH_ISSTORE|HV_FETCH_LVALUE)) { + /* if the hash has a name report it also */ + if (name) { + /* But allow DESTROY calls in restricted coretypes */ + if (strNEc(key, "DESTROY") && strNEc(key, "AUTOLOAD")) { + SV *msg = newSVpvs_flags("Attempt to store key '%" SVf "' in" + " the readonly hash '%%", SVs_TEMP); + sv_cathek(msg, name); + sv_catpvs(msg, "::'"); + hv_notallowed(flags, key, klen, SvPVX(msg)); + } + } + else { + hv_notallowed(flags, key, klen, + "Attempt to store key '%" SVf "' in" + " a readonly hash"); + } + } + else if ( HvRESTRICTED(hv) ) { + if (name) { + /* But allow DESTROY calls in restricted coretypes */ + if (strNEc(key, "DESTROY") && strNEc(key, "AUTOLOAD")) { + SV *msg = newSVpvs_flags("Attempt to access disallowed key '%" SVf "' in" + " the restricted hash '%%", SVs_TEMP); + sv_cathek(msg, name); + sv_catpvs(msg, "::'"); + hv_notallowed(flags, key, klen, SvPVX(msg)); + } + } else { + hv_notallowed(flags, key, klen, + "Attempt to fetch disallowed key '%" SVf "' in" + " a restricted hash"); } - } else { - hv_notallowed(flags, key, klen, - "Attempt to access disallowed key '%" SVf "' in" - " a restricted hash"); } } if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { @@ -2051,7 +2070,7 @@ Perl_newHVhv(pTHX_ HV *ohv) /* Copy the linked list of entries. */ for (; oent; oent = HeNEXT(oent)) { - const HEK *hek = HeKEY_hek(oent); + HEK *const hek = HeKEY_hek(oent); HE * const ent = new_HE(); SV * const val = HeVAL(oent); @@ -2159,7 +2178,7 @@ STATIC SV* S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry) { SV *val; - const HEK* hek = HeKEY_hek(entry); + HEK *const hek = HeKEY_hek(entry); PERL_ARGS_ASSERT_HV_FREE_ENT_RET; diff --git a/hv.h b/hv.h index 38f60fb0af6..9457af45f54 100644 --- a/hv.h +++ b/hv.h @@ -468,6 +468,10 @@ C. #define HvSMALL(hv) (HvTOTALKEYS(hv) <= PERL_HV_SMALL_MAX) #define XHvSMALL(xhv) (XHvTOTALKEYS(xhv) <= PERL_HV_SMALL_MAX) +#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/pad.c b/pad.c index 135d2fbf94a..7840be8faf7 100644 --- a/pad.c +++ b/pad.c @@ -2426,12 +2426,12 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) SV * const retsv = sv ? (sv) : sv_newmortal(); if (SvTYPE(cv) == SVt_PVCV) { if (CvNAMED(cv)) { - HEK *const cvname = CvNAME_HEK(cv); + HEK * const cvname = CvNAME_HEK(cv); if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) { sv_sethek(retsv, cvname); if (HEK_UTF8(cvname)) SvUTF8_on(retsv); } else { - const HV *const pkg = CvSTASH(cv); + const HV * const pkg = CvSTASH(cv); if (flags & CV_NAME_NOMAIN && HvNAMELEN_get(pkg) == 4 && strnEQ(HEK_KEY(HvNAME_HEK_NN(pkg)), "main", 4)) @@ -2439,7 +2439,7 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) sv_sethek(retsv, cvname); if (HEK_UTF8(cvname)) SvUTF8_on(retsv); } else { - const HEK *const hvname = HvNAME_HEK(pkg); + const HEK * const hvname = HvNAME_HEK(pkg); sv_sethek(retsv, hvname); sv_catpvs(retsv, "::"); sv_cathek(retsv, cvname); diff --git a/scope.c b/scope.c index 274e72a997a..435774b09c7 100644 --- a/scope.c +++ b/scope.c @@ -1257,15 +1257,24 @@ Perl_leave_scope(pTHX_ I32 base) (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon")); /* Can clear pad variable in place? */ - if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) { - - /* these flags are the union of all the relevant flags - * in the individual conditions within */ - if (UNLIKELY(SvFLAGS(sv) & ( - SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/ - | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */ - | SVf_OOK - | SVf_THINKFIRST))) + if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { + /* + * if a my variable that was made readonly is going out of + * scope, we want to remove the readonlyness so that it can + * go out of scope quietly + */ + + 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)) { /* if a my variable that was made readonly is * going out of scope, we want to remove the diff --git a/sv.h b/sv.h index d1e0470c39c..a25075a270f 100644 --- a/sv.h +++ b/sv.h @@ -495,7 +495,11 @@ perform the upgrade if necessary. See C>. including PVLV-as-regex. See isREGEXP(). */ -#define SVphv_CLASS SVf_FAKE /* DAPM wants it for vtables, cperl for classes */ +#define SVphv_CLASS (SVf_FAKE|SVp_POK) + /* 4: HV: READONLY hash is RESTRICTED, + fetches for missing keys will die. */ +#define SVphv_RESTRICTED (SVf_FAKE|SVf_BREAK) + #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 0b813e76246..98f1940b5e2 100644 --- a/universal.c +++ b/universal.c @@ -545,6 +545,44 @@ XS(XS_utf8_unicode_to_native) XSRETURN(1); } +XS(XS_Internals_HvRESTRICTED); /* prototype to pass -Wmissing-prototypes */ +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); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { @@ -1403,6 +1441,7 @@ static const struct xsub_details details[] = { {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, {"Internals::HvCLASS", XS_Internals_HvCLASS, "\\[$%];$"}, {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, + {"Internals::HvRESTRICTED", XS_Internals_HvRESTRICTED, "\\%;$"}, {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, {"constant::_make_const", XS_constant__make_const, "\\[$@]"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},