1N/A#!/usr/bin/perl -Tw
1N/A
1N/ABEGIN {
1N/A if( $ENV{PERL_CORE} ) {
1N/A @INC = '../lib';
1N/A chdir 't';
1N/A }
1N/A}
1N/Ause Test::More tests => 173;
1N/Ause strict;
1N/A
1N/Amy @Exported_Funcs;
1N/ABEGIN {
1N/A @Exported_Funcs = qw(lock_keys unlock_keys
1N/A lock_value unlock_value
1N/A lock_hash unlock_hash
1N/A hash_seed
1N/A );
1N/A use_ok 'Hash::Util', @Exported_Funcs;
1N/A}
1N/Aforeach my $func (@Exported_Funcs) {
1N/A can_ok __PACKAGE__, $func;
1N/A}
1N/A
1N/Amy %hash = (foo => 42, bar => 23, locked => 'yep');
1N/Alock_keys(%hash);
1N/Aeval { $hash{baz} = 99; };
1N/Alike( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
1N/A 'lock_keys()');
1N/Ais( $hash{bar}, 23 );
1N/Aok( !exists $hash{baz} );
1N/A
1N/Adelete $hash{bar};
1N/Aok( !exists $hash{bar} );
1N/A$hash{bar} = 69;
1N/Ais( $hash{bar}, 69 );
1N/A
1N/Aeval { () = $hash{i_dont_exist} };
1N/Alike( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
1N/A
1N/Alock_value(%hash, 'locked');
1N/Aeval { print "# oops" if $hash{four} };
1N/Alike( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
1N/A
1N/Aeval { $hash{"\x{2323}"} = 3 };
1N/Alike( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
1N/A 'wide hex key' );
1N/A
1N/Aeval { delete $hash{locked} };
1N/Alike( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
1N/A 'trying to delete a locked key' );
1N/Aeval { $hash{locked} = 42; };
1N/Alike( $@, qr/^Modification of a read-only value attempted/,
1N/A 'trying to change a locked key' );
1N/Ais( $hash{locked}, 'yep' );
1N/A
1N/Aeval { delete $hash{I_dont_exist} };
1N/Alike( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
1N/A 'trying to delete a key that doesnt exist' );
1N/A
1N/Aok( !exists $hash{I_dont_exist} );
1N/A
1N/Aunlock_keys(%hash);
1N/A$hash{I_dont_exist} = 42;
1N/Ais( $hash{I_dont_exist}, 42, 'unlock_keys' );
1N/A
1N/Aeval { $hash{locked} = 42; };
1N/Alike( $@, qr/^Modification of a read-only value attempted/,
1N/A ' individual key still readonly' );
1N/Aeval { delete $hash{locked} },
1N/Ais( $@, '', ' but can be deleted :(' );
1N/A
1N/Aunlock_value(%hash, 'locked');
1N/A$hash{locked} = 42;
1N/Ais( $hash{locked}, 42, 'unlock_value' );
1N/A
1N/A
1N/A{
1N/A my %hash = ( foo => 42, locked => 23 );
1N/A
1N/A lock_keys(%hash);
1N/A eval { %hash = ( wubble => 42 ) }; # we know this will bomb
1N/A like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
1N/A unlock_keys(%hash);
1N/A}
1N/A
1N/A{
1N/A my %hash = (KEY => 'val', RO => 'val');
1N/A lock_keys(%hash);
1N/A lock_value(%hash, 'RO');
1N/A
1N/A eval { %hash = (KEY => 1) };
1N/A like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
1N/A}
1N/A
1N/A{
1N/A my %hash = (KEY => 1, RO => 2);
1N/A lock_keys(%hash);
1N/A eval { %hash = (KEY => 1, RO => 2) };
1N/A is( $@, '');
1N/A}
1N/A
1N/A
1N/A
1N/A{
1N/A my %hash = ();
1N/A lock_keys(%hash, qw(foo bar));
1N/A is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
1N/A $hash{foo} = 42;
1N/A is( keys %hash, 1 );
1N/A eval { $hash{wibble} = 42 };
1N/A like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
1N/A ' locked');
1N/A
1N/A unlock_keys(%hash);
1N/A eval { $hash{wibble} = 23; };
1N/A is( $@, '', 'unlock_keys' );
1N/A}
1N/A
1N/A
1N/A{
1N/A my %hash = (foo => 42, bar => undef, baz => 0);
1N/A lock_keys(%hash, qw(foo bar baz up down));
1N/A is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' );
1N/A is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
1N/A
1N/A eval { $hash{up} = 42; };
1N/A is( $@, '' );
1N/A
1N/A eval { $hash{wibble} = 23 };
1N/A like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' );
1N/A}
1N/A
1N/A
1N/A{
1N/A my %hash = (foo => 42, bar => undef);
1N/A eval { lock_keys(%hash, qw(foo baz)); };
1N/A is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
1N/A "set at %s line %d\n", __FILE__, __LINE__ - 2) );
1N/A}
1N/A
1N/A
1N/A{
1N/A my %hash = (foo => 42, bar => 23);
1N/A lock_hash( %hash );
1N/A
1N/A ok( Internals::SvREADONLY(%hash) );
1N/A ok( Internals::SvREADONLY($hash{foo}) );
1N/A ok( Internals::SvREADONLY($hash{bar}) );
1N/A
1N/A unlock_hash ( %hash );
1N/A
1N/A ok( !Internals::SvREADONLY(%hash) );
1N/A ok( !Internals::SvREADONLY($hash{foo}) );
1N/A ok( !Internals::SvREADONLY($hash{bar}) );
1N/A}
1N/A
1N/A
1N/Alock_keys(%ENV);
1N/Aeval { () = $ENV{I_DONT_EXIST} };
1N/Alike( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV');
1N/A
1N/A{
1N/A my %hash;
1N/A
1N/A lock_keys(%hash, 'first');
1N/A
1N/A is (scalar keys %hash, 0, "place holder isn't a key");
1N/A $hash{first} = 1;
1N/A is (scalar keys %hash, 1, "we now have a key");
1N/A delete $hash{first};
1N/A is (scalar keys %hash, 0, "now no key");
1N/A
1N/A unlock_keys(%hash);
1N/A
1N/A $hash{interregnum} = 1.5;
1N/A is (scalar keys %hash, 1, "key again");
1N/A delete $hash{interregnum};
1N/A is (scalar keys %hash, 0, "no key again");
1N/A
1N/A lock_keys(%hash, 'second');
1N/A
1N/A is (scalar keys %hash, 0, "place holder isn't a key");
1N/A
1N/A eval {$hash{zeroeth} = 0};
1N/A like ($@,
1N/A qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
1N/A 'locked key never mentioned before should fail');
1N/A eval {$hash{first} = -1};
1N/A like ($@,
1N/A qr/^Attempt to access disallowed key 'first' in a restricted hash/,
1N/A 'previously locked place holders should also fail');
1N/A is (scalar keys %hash, 0, "and therefore there are no keys");
1N/A $hash{second} = 1;
1N/A is (scalar keys %hash, 1, "we now have just one key");
1N/A delete $hash{second};
1N/A is (scalar keys %hash, 0, "back to zero");
1N/A
1N/A unlock_keys(%hash); # We have deliberately left a placeholder.
1N/A
1N/A $hash{void} = undef;
1N/A $hash{nowt} = undef;
1N/A
1N/A is (scalar keys %hash, 2, "two keys, values both undef");
1N/A
1N/A lock_keys(%hash);
1N/A
1N/A is (scalar keys %hash, 2, "still two keys after locking");
1N/A
1N/A eval {$hash{second} = -1};
1N/A like ($@,
1N/A qr/^Attempt to access disallowed key 'second' in a restricted hash/,
1N/A 'previously locked place holders should fail');
1N/A
1N/A is ($hash{void}, undef,
1N/A "undef values should not be misunderstood as placeholders");
1N/A is ($hash{nowt}, undef,
1N/A "undef values should not be misunderstood as placeholders (again)");
1N/A}
1N/A
1N/A{
1N/A # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant
1N/A # bug whereby hash iterators could lose hash keys (and values, as the code
1N/A # is common) for restricted hashes.
1N/A
1N/A my @keys = qw(small medium large);
1N/A
1N/A # There should be no difference whether it is restricted or not
1N/A foreach my $lock (0, 1) {
1N/A # Try setting all combinations of the 3 keys
1N/A foreach my $usekeys (0..7) {
1N/A my @usekeys;
1N/A for my $bits (0,1,2) {
1N/A push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
1N/A }
1N/A my %clean = map {$_ => length $_} @usekeys;
1N/A my %target;
1N/A lock_keys ( %target, @keys ) if $lock;
1N/A
1N/A while (my ($k, $v) = each %clean) {
1N/A $target{$k} = $v;
1N/A }
1N/A
1N/A my $message
1N/A = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
1N/A
1N/A is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
1N/A is (scalar values %target, scalar values %clean,
1N/A "scalar values for $message");
1N/A # Yes. All these sorts are necessary. Even for "identical hashes"
1N/A # Because the data dependency of the test involves two of the strings
1N/A # colliding on the same bucket, so the iterator order (output of keys,
1N/A # values, each) depends on the addition order in the hash. And locking
1N/A # the keys of the hash involves behind the scenes key additions.
1N/A is_deeply( [sort keys %target] , [sort keys %clean],
1N/A "list keys for $message");
1N/A is_deeply( [sort values %target] , [sort values %clean],
1N/A "list values for $message");
1N/A
1N/A is_deeply( [sort %target] , [sort %clean],
1N/A "hash in list context for $message");
1N/A
1N/A my (@clean, @target);
1N/A while (my ($k, $v) = each %clean) {
1N/A push @clean, $k, $v;
1N/A }
1N/A while (my ($k, $v) = each %target) {
1N/A push @target, $k, $v;
1N/A }
1N/A
1N/A is_deeply( [sort @target] , [sort @clean],
1N/A "iterating with each for $message");
1N/A }
1N/A }
1N/A}
1N/A
1N/A# Check clear works on locked empty hashes - SEGVs on 5.8.2.
1N/A{
1N/A my %hash;
1N/A lock_hash(%hash);
1N/A %hash = ();
1N/A ok(keys(%hash) == 0, 'clear empty lock_hash() hash');
1N/A}
1N/A{
1N/A my %hash;
1N/A lock_keys(%hash);
1N/A %hash = ();
1N/A ok(keys(%hash) == 0, 'clear empty lock_keys() hash');
1N/A}
1N/A
1N/Amy $hash_seed = hash_seed();
1N/Aok($hash_seed >= 0, "hash_seed $hash_seed");
1N/A
1N/A{
1N/A package Minder;
1N/A my $counter;
1N/A sub DESTROY {
1N/A --$counter;
1N/A }
1N/A sub new {
1N/A ++$counter;
1N/A bless [], __PACKAGE__;
1N/A }
1N/A package main;
1N/A
1N/A for my $state ('', 'locked') {
1N/A my $a = Minder->new();
1N/A is ($counter, 1, "There is 1 object $state");
1N/A my %hash;
1N/A $hash{a} = $a;
1N/A is ($counter, 1, "There is still 1 object $state");
1N/A
1N/A lock_keys(%hash) if $state;
1N/A
1N/A is ($counter, 1, "There is still 1 object $state");
1N/A undef $a;
1N/A is ($counter, 1, "Still 1 object $state");
1N/A delete $hash{a};
1N/A is ($counter, 0, "0 objects when hash key is deleted $state");
1N/A $hash{a} = undef;
1N/A is ($counter, 0, "Still 0 objects $state");
1N/A %hash = ();
1N/A is ($counter, 0, "0 objects after clear $state");
1N/A }
1N/A}