X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHash%2FUtil.t;h=1c77728c27a600af188ae8f8dc5902e09925007f;hb=f1317c8d183c687b884dabebf7d01723441851a4;hp=1046e32c54cec24c1be583bb7859bd17976f6bb2;hpb=2393f1b901d4e694bd945211b6a0392db1b3cf57;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t index 1046e32..1c77728 100644 --- a/lib/Hash/Util.t +++ b/lib/Hash/Util.t @@ -6,13 +6,15 @@ BEGIN { chdir 't'; } } -use Test::More tests => 45; +use Test::More tests => 159; +use strict; my @Exported_Funcs; BEGIN { @Exported_Funcs = qw(lock_keys unlock_keys lock_value unlock_value lock_hash unlock_hash + hash_seed ); use_ok 'Hash::Util', @Exported_Funcs; } @@ -73,21 +75,12 @@ $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 restricted 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' ); + like( $@, qr/^Attempt to access disallowed key 'wubble'/ ); unlock_keys(%hash); } @@ -97,16 +90,14 @@ TODO: { lock_value(%hash, 'RO'); eval { %hash = (KEY => 1) }; - like( $@, qr/^Attempt to clear a restricted hash/ ); + like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted 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 restricted hash/ ); + is( $@, ''); } @@ -168,3 +159,134 @@ TODO: { lock_keys(%ENV); eval { () = $ENV{I_DONT_EXIST} }; like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); + +{ + my %hash; + + lock_keys(%hash, '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, 'second'); + + is (scalar keys %hash, 0, "place holder isn't a key"); + + eval {$hash{zeroeth} = 0}; + like ($@, + qr/^Attempt to access 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/, + '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); + + is (scalar keys %hash, 2, "still two keys after locking"); + + eval {$hash{second} = -1}; + like ($@, + qr/^Attempt to access 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, @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); + %hash = (); + ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); +} +{ + my %hash; + lock_keys(%hash); + %hash = (); + ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); +} + +my $hash_seed = hash_seed(); +ok($hash_seed >= 0, "hash_seed $hash_seed");