Skip to content
This repository has been archived by the owner on Jun 1, 2023. It is now read-only.

Commit

Permalink
HvRESTRICTED: separate restricted fetch
Browse files Browse the repository at this point in the history 
from readonly behavior for hashes [cperl #57]
  • Loading branch information
@demerphq @rurban
demerphq authored and rurban committed Sep 18, 2018
1 parent 09e4aca commit e414395
Show file tree
Hide file tree
Showing 11 changed files with 750 additions and 51 deletions.
1 change: 1 addition & 0 deletions MANIFEST
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions dump.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,"},
Expand Down
39 changes: 27 additions & 12 deletions ext/Hash-Util/lib/Hash/Util.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ) {
Expand All @@ -190,13 +193,15 @@ 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) {
delete $hash->{$k} unless $original_keys{$k};
}
}
else {
Internals::HvRESTRICTED %$hash, 1 unless $opts && $opts->{unrestricted};
Internals::SvREADONLY %$hash, 1;
}

Expand All @@ -207,6 +212,7 @@ sub unlock_ref_keys {
my $hash = shift;

Internals::SvREADONLY %$hash, 0;
Internals::HvRESTRICTED %$hash, 0;
return $hash;
}

Expand Down Expand Up @@ -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) {
Expand All @@ -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
Expand Down Expand Up @@ -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);
Expand All @@ -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<lock_hash_recurse>
Expand All @@ -368,30 +381,32 @@ 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);
}
return $hash
}

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;
}

Expand Down
22 changes: 11 additions & 11 deletions ext/Hash-Util/t/Util.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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}' );
Expand All @@ -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} };
Expand Down Expand Up @@ -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);
}

Expand Down Expand Up @@ -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);
Expand All @@ -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"' );
}

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand All @@ -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,
Expand Down
Loading

0 comments on commit e414395

Please sign in to comment.