1#!/usr/bin/perl -Tw 2 3BEGIN { 4 if( $ENV{PERL_CORE} ) { 5 @INC = '../lib'; 6 chdir 't'; 7 } 8} 9use Test::More tests => 173; 10use strict; 11 12my @Exported_Funcs; 13BEGIN { 14 @Exported_Funcs = qw(lock_keys unlock_keys 15 lock_value unlock_value 16 lock_hash unlock_hash 17 hash_seed 18 ); 19 use_ok 'Hash::Util', @Exported_Funcs; 20} 21foreach my $func (@Exported_Funcs) { 22 can_ok __PACKAGE__, $func; 23} 24 25my %hash = (foo => 42, bar => 23, locked => 'yep'); 26lock_keys(%hash); 27eval { $hash{baz} = 99; }; 28like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, 29 'lock_keys()'); 30is( $hash{bar}, 23 ); 31ok( !exists $hash{baz} ); 32 33delete $hash{bar}; 34ok( !exists $hash{bar} ); 35$hash{bar} = 69; 36is( $hash{bar}, 69 ); 37 38eval { () = $hash{i_dont_exist} }; 39like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ ); 40 41lock_value(%hash, 'locked'); 42eval { print "# oops" if $hash{four} }; 43like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ ); 44 45eval { $hash{"\x{2323}"} = 3 }; 46like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, 47 'wide hex key' ); 48 49eval { delete $hash{locked} }; 50like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, 51 'trying to delete a locked key' ); 52eval { $hash{locked} = 42; }; 53like( $@, qr/^Modification of a read-only value attempted/, 54 'trying to change a locked key' ); 55is( $hash{locked}, 'yep' ); 56 57eval { delete $hash{I_dont_exist} }; 58like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, 59 'trying to delete a key that doesnt exist' ); 60 61ok( !exists $hash{I_dont_exist} ); 62 63unlock_keys(%hash); 64$hash{I_dont_exist} = 42; 65is( $hash{I_dont_exist}, 42, 'unlock_keys' ); 66 67eval { $hash{locked} = 42; }; 68like( $@, qr/^Modification of a read-only value attempted/, 69 ' individual key still readonly' ); 70eval { delete $hash{locked} }, 71is( $@, '', ' but can be deleted :(' ); 72 73unlock_value(%hash, 'locked'); 74$hash{locked} = 42; 75is( $hash{locked}, 42, 'unlock_value' ); 76 77 78{ 79 my %hash = ( foo => 42, locked => 23 ); 80 81 lock_keys(%hash); 82 eval { %hash = ( wubble => 42 ) }; # we know this will bomb 83 like( $@, qr/^Attempt to access disallowed key 'wubble'/ ); 84 unlock_keys(%hash); 85} 86 87{ 88 my %hash = (KEY => 'val', RO => 'val'); 89 lock_keys(%hash); 90 lock_value(%hash, 'RO'); 91 92 eval { %hash = (KEY => 1) }; 93 like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ ); 94} 95 96{ 97 my %hash = (KEY => 1, RO => 2); 98 lock_keys(%hash); 99 eval { %hash = (KEY => 1, RO => 2) }; 100 is( $@, ''); 101} 102 103 104 105{ 106 my %hash = (); 107 lock_keys(%hash, qw(foo bar)); 108 is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' ); 109 $hash{foo} = 42; 110 is( keys %hash, 1 ); 111 eval { $hash{wibble} = 42 }; 112 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, 113 ' locked'); 114 115 unlock_keys(%hash); 116 eval { $hash{wibble} = 23; }; 117 is( $@, '', 'unlock_keys' ); 118} 119 120 121{ 122 my %hash = (foo => 42, bar => undef, baz => 0); 123 lock_keys(%hash, qw(foo bar baz up down)); 124 is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' ); 125 is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } ); 126 127 eval { $hash{up} = 42; }; 128 is( $@, '' ); 129 130 eval { $hash{wibble} = 23 }; 131 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' ); 132} 133 134 135{ 136 my %hash = (foo => 42, bar => undef); 137 eval { lock_keys(%hash, qw(foo baz)); }; 138 is( $@, sprintf("Hash has key 'bar' which is not in the new key ". 139 "set at %s line %d\n", __FILE__, __LINE__ - 2) ); 140} 141 142 143{ 144 my %hash = (foo => 42, bar => 23); 145 lock_hash( %hash ); 146 147 ok( Internals::SvREADONLY(%hash) ); 148 ok( Internals::SvREADONLY($hash{foo}) ); 149 ok( Internals::SvREADONLY($hash{bar}) ); 150 151 unlock_hash ( %hash ); 152 153 ok( !Internals::SvREADONLY(%hash) ); 154 ok( !Internals::SvREADONLY($hash{foo}) ); 155 ok( !Internals::SvREADONLY($hash{bar}) ); 156} 157 158 159lock_keys(%ENV); 160eval { () = $ENV{I_DONT_EXIST} }; 161like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); 162 163{ 164 my %hash; 165 166 lock_keys(%hash, 'first'); 167 168 is (scalar keys %hash, 0, "place holder isn't a key"); 169 $hash{first} = 1; 170 is (scalar keys %hash, 1, "we now have a key"); 171 delete $hash{first}; 172 is (scalar keys %hash, 0, "now no key"); 173 174 unlock_keys(%hash); 175 176 $hash{interregnum} = 1.5; 177 is (scalar keys %hash, 1, "key again"); 178 delete $hash{interregnum}; 179 is (scalar keys %hash, 0, "no key again"); 180 181 lock_keys(%hash, 'second'); 182 183 is (scalar keys %hash, 0, "place holder isn't a key"); 184 185 eval {$hash{zeroeth} = 0}; 186 like ($@, 187 qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, 188 'locked key never mentioned before should fail'); 189 eval {$hash{first} = -1}; 190 like ($@, 191 qr/^Attempt to access disallowed key 'first' in a restricted hash/, 192 'previously locked place holders should also fail'); 193 is (scalar keys %hash, 0, "and therefore there are no keys"); 194 $hash{second} = 1; 195 is (scalar keys %hash, 1, "we now have just one key"); 196 delete $hash{second}; 197 is (scalar keys %hash, 0, "back to zero"); 198 199 unlock_keys(%hash); # We have deliberately left a placeholder. 200 201 $hash{void} = undef; 202 $hash{nowt} = undef; 203 204 is (scalar keys %hash, 2, "two keys, values both undef"); 205 206 lock_keys(%hash); 207 208 is (scalar keys %hash, 2, "still two keys after locking"); 209 210 eval {$hash{second} = -1}; 211 like ($@, 212 qr/^Attempt to access disallowed key 'second' in a restricted hash/, 213 'previously locked place holders should fail'); 214 215 is ($hash{void}, undef, 216 "undef values should not be misunderstood as placeholders"); 217 is ($hash{nowt}, undef, 218 "undef values should not be misunderstood as placeholders (again)"); 219} 220 221{ 222 # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant 223 # bug whereby hash iterators could lose hash keys (and values, as the code 224 # is common) for restricted hashes. 225 226 my @keys = qw(small medium large); 227 228 # There should be no difference whether it is restricted or not 229 foreach my $lock (0, 1) { 230 # Try setting all combinations of the 3 keys 231 foreach my $usekeys (0..7) { 232 my @usekeys; 233 for my $bits (0,1,2) { 234 push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); 235 } 236 my %clean = map {$_ => length $_} @usekeys; 237 my %target; 238 lock_keys ( %target, @keys ) if $lock; 239 240 while (my ($k, $v) = each %clean) { 241 $target{$k} = $v; 242 } 243 244 my $message 245 = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; 246 247 is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); 248 is (scalar values %target, scalar values %clean, 249 "scalar values for $message"); 250 # Yes. All these sorts are necessary. Even for "identical hashes" 251 # Because the data dependency of the test involves two of the strings 252 # colliding on the same bucket, so the iterator order (output of keys, 253 # values, each) depends on the addition order in the hash. And locking 254 # the keys of the hash involves behind the scenes key additions. 255 is_deeply( [sort keys %target] , [sort keys %clean], 256 "list keys for $message"); 257 is_deeply( [sort values %target] , [sort values %clean], 258 "list values for $message"); 259 260 is_deeply( [sort %target] , [sort %clean], 261 "hash in list context for $message"); 262 263 my (@clean, @target); 264 while (my ($k, $v) = each %clean) { 265 push @clean, $k, $v; 266 } 267 while (my ($k, $v) = each %target) { 268 push @target, $k, $v; 269 } 270 271 is_deeply( [sort @target] , [sort @clean], 272 "iterating with each for $message"); 273 } 274 } 275} 276 277# Check clear works on locked empty hashes - SEGVs on 5.8.2. 278{ 279 my %hash; 280 lock_hash(%hash); 281 %hash = (); 282 ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); 283} 284{ 285 my %hash; 286 lock_keys(%hash); 287 %hash = (); 288 ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); 289} 290 291my $hash_seed = hash_seed(); 292ok($hash_seed >= 0, "hash_seed $hash_seed"); 293 294{ 295 package Minder; 296 my $counter; 297 sub DESTROY { 298 --$counter; 299 } 300 sub new { 301 ++$counter; 302 bless [], __PACKAGE__; 303 } 304 package main; 305 306 for my $state ('', 'locked') { 307 my $a = Minder->new(); 308 is ($counter, 1, "There is 1 object $state"); 309 my %hash; 310 $hash{a} = $a; 311 is ($counter, 1, "There is still 1 object $state"); 312 313 lock_keys(%hash) if $state; 314 315 is ($counter, 1, "There is still 1 object $state"); 316 undef $a; 317 is ($counter, 1, "Still 1 object $state"); 318 delete $hash{a}; 319 is ($counter, 0, "0 objects when hash key is deleted $state"); 320 $hash{a} = undef; 321 is ($counter, 0, "Still 0 objects $state"); 322 %hash = (); 323 is ($counter, 0, "0 objects after clear $state"); 324 } 325} 326