X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHash%2FUtil.t;h=8ed557f1a3cd9cf94cd32cbaaccc636052801001;hb=f1c8c9362c4d1029d2c52ffe1e972f0f0b3d5771;hp=a42a52e03c9bd2fcc5051472246e9e8e595a9cc3;hpb=dfd4ef2f849f6c6c1ef68fdf03041001be25ade9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t index a42a52e..8ed557f 100644 --- a/lib/Hash/Util.t +++ b/lib/Hash/Util.t @@ -6,13 +6,15 @@ BEGIN { chdir 't'; } } -use Test::More tests => 55; +use Test::More tests => 173; +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( $@, ''); } @@ -202,4 +193,133 @@ like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted ha 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"); + +{ + 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) 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"); + } }