1#!/usr/bin/perl -Tw 2 3BEGIN { 4 if ($ENV{PERL_CORE}) { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 require Config; import Config; 8 keys %Config; # Silence warning 9 if ($Config{extensions} !~ /\bHash\/Util\b/) { 10 print "1..0 # Skip: Hash::Util was not built\n"; 11 exit 0; 12 } 13 } 14} 15 16use strict; 17use Test::More; 18my @Exported_Funcs; 19BEGIN { 20 @Exported_Funcs = qw( 21 hash_seed all_keys 22 lock_keys unlock_keys 23 lock_value unlock_value 24 lock_hash unlock_hash 25 lock_keys_plus hash_locked 26 hidden_keys legal_keys 27 28 lock_ref_keys unlock_ref_keys 29 lock_ref_value unlock_ref_value 30 lock_hashref unlock_hashref 31 lock_ref_keys_plus hashref_locked 32 hidden_ref_keys legal_ref_keys 33 hv_store 34 35 ); 36 plan tests => 204 + @Exported_Funcs; 37 use_ok 'Hash::Util', @Exported_Funcs; 38} 39foreach my $func (@Exported_Funcs) { 40 can_ok __PACKAGE__, $func; 41} 42 43my %hash = (foo => 42, bar => 23, locked => 'yep'); 44lock_keys(%hash); 45eval { $hash{baz} = 99; }; 46like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, 47 'lock_keys()'); 48is( $hash{bar}, 23 ); 49ok( !exists $hash{baz},'!exists $hash{baz}' ); 50 51delete $hash{bar}; 52ok( !exists $hash{bar},'!exists $hash{bar}' ); 53$hash{bar} = 69; 54is( $hash{bar}, 69 ,'$hash{bar} == 69'); 55 56eval { () = $hash{i_dont_exist} }; 57like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/, 58 'Disallowed 1' ); 59 60lock_value(%hash, 'locked'); 61eval { print "# oops" if $hash{four} }; 62like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/, 63 'Disallowed 2' ); 64 65eval { $hash{"\x{2323}"} = 3 }; 66like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, 67 'wide hex key' ); 68 69eval { delete $hash{locked} }; 70like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, 71 'trying to delete a locked key' ); 72eval { $hash{locked} = 42; }; 73like( $@, qr/^Modification of a read-only value attempted/, 74 'trying to change a locked key' ); 75is( $hash{locked}, 'yep' ); 76 77eval { delete $hash{I_dont_exist} }; 78like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, 79 'trying to delete a key that doesnt exist' ); 80 81ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' ); 82 83unlock_keys(%hash); 84$hash{I_dont_exist} = 42; 85is( $hash{I_dont_exist}, 42, 'unlock_keys' ); 86 87eval { $hash{locked} = 42; }; 88like( $@, qr/^Modification of a read-only value attempted/, 89 ' individual key still readonly' ); 90eval { delete $hash{locked} }, 91is( $@, '', ' but can be deleted :(' ); 92 93unlock_value(%hash, 'locked'); 94$hash{locked} = 42; 95is( $hash{locked}, 42, 'unlock_value' ); 96 97 98{ 99 my %hash = ( foo => 42, locked => 23 ); 100 101 lock_keys(%hash); 102 eval { %hash = ( wubble => 42 ) }; # we know this will bomb 103 like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' ); 104 unlock_keys(%hash); 105} 106 107{ 108 my %hash = (KEY => 'val', RO => 'val'); 109 lock_keys(%hash); 110 lock_value(%hash, 'RO'); 111 112 eval { %hash = (KEY => 1) }; 113 like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ ); 114} 115 116{ 117 my %hash = (KEY => 1, RO => 2); 118 lock_keys(%hash); 119 eval { %hash = (KEY => 1, RO => 2) }; 120 is( $@, ''); 121} 122 123 124 125{ 126 my %hash = (); 127 lock_keys(%hash, qw(foo bar)); 128 is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' ); 129 $hash{foo} = 42; 130 is( keys %hash, 1 ); 131 eval { $hash{wibble} = 42 }; 132 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, 133 'write threw error (locked)'); 134 135 unlock_keys(%hash); 136 eval { $hash{wibble} = 23; }; 137 is( $@, '', 'unlock_keys' ); 138} 139 140 141{ 142 my %hash = (foo => 42, bar => undef, baz => 0); 143 lock_keys(%hash, qw(foo bar baz up down)); 144 is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' ); 145 is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 },'is_deeply' ); 146 147 eval { $hash{up} = 42; }; 148 is( $@, '','No error 1' ); 149 150 eval { $hash{wibble} = 23 }; 151 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, 152 'locked "wibble"' ); 153} 154 155 156{ 157 my %hash = (foo => 42, bar => undef); 158 eval { lock_keys(%hash, qw(foo baz)); }; 159 is( $@, sprintf("Hash has key 'bar' which is not in the new key ". 160 "set at %s line %d\n", __FILE__, __LINE__ - 2), 161 'carp test' ); 162} 163 164 165{ 166 my %hash = (foo => 42, bar => 23); 167 lock_hash( %hash ); 168 169 ok( Internals::SvREADONLY(%hash),'Was locked %hash' ); 170 ok( Internals::SvREADONLY($hash{foo}),'Was locked $hash{foo}' ); 171 ok( Internals::SvREADONLY($hash{bar}),'Was locked $hash{bar}' ); 172 173 unlock_hash ( %hash ); 174 175 ok( !Internals::SvREADONLY(%hash),'Was unlocked %hash' ); 176 ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' ); 177 ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' ); 178} 179 180 181lock_keys(%ENV); 182eval { () = $ENV{I_DONT_EXIST} }; 183like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); 184 185{ 186 my %hash; 187 188 lock_keys(%hash, 'first'); 189 190 is (scalar keys %hash, 0, "place holder isn't a key"); 191 $hash{first} = 1; 192 is (scalar keys %hash, 1, "we now have a key"); 193 delete $hash{first}; 194 is (scalar keys %hash, 0, "now no key"); 195 196 unlock_keys(%hash); 197 198 $hash{interregnum} = 1.5; 199 is (scalar keys %hash, 1, "key again"); 200 delete $hash{interregnum}; 201 is (scalar keys %hash, 0, "no key again"); 202 203 lock_keys(%hash, 'second'); 204 205 is (scalar keys %hash, 0, "place holder isn't a key"); 206 207 eval {$hash{zeroeth} = 0}; 208 like ($@, 209 qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, 210 'locked key never mentioned before should fail'); 211 eval {$hash{first} = -1}; 212 like ($@, 213 qr/^Attempt to access disallowed key 'first' in a restricted hash/, 214 'previously locked place holders should also fail'); 215 is (scalar keys %hash, 0, "and therefore there are no keys"); 216 $hash{second} = 1; 217 is (scalar keys %hash, 1, "we now have just one key"); 218 delete $hash{second}; 219 is (scalar keys %hash, 0, "back to zero"); 220 221 unlock_keys(%hash); # We have deliberately left a placeholder. 222 223 $hash{void} = undef; 224 $hash{nowt} = undef; 225 226 is (scalar keys %hash, 2, "two keys, values both undef"); 227 228 lock_keys(%hash); 229 230 is (scalar keys %hash, 2, "still two keys after locking"); 231 232 eval {$hash{second} = -1}; 233 like ($@, 234 qr/^Attempt to access disallowed key 'second' in a restricted hash/, 235 'previously locked place holders should fail'); 236 237 is ($hash{void}, undef, 238 "undef values should not be misunderstood as placeholders"); 239 is ($hash{nowt}, undef, 240 "undef values should not be misunderstood as placeholders (again)"); 241} 242 243{ 244 # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant 245 # bug whereby hash iterators could lose hash keys (and values, as the code 246 # is common) for restricted hashes. 247 248 my @keys = qw(small medium large); 249 250 # There should be no difference whether it is restricted or not 251 foreach my $lock (0, 1) { 252 # Try setting all combinations of the 3 keys 253 foreach my $usekeys (0..7) { 254 my @usekeys; 255 for my $bits (0,1,2) { 256 push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); 257 } 258 my %clean = map {$_ => length $_} @usekeys; 259 my %target; 260 lock_keys ( %target, @keys ) if $lock; 261 262 while (my ($k, $v) = each %clean) { 263 $target{$k} = $v; 264 } 265 266 my $message 267 = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; 268 269 is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); 270 is (scalar values %target, scalar values %clean, 271 "scalar values for $message"); 272 # Yes. All these sorts are necessary. Even for "identical hashes" 273 # Because the data dependency of the test involves two of the strings 274 # colliding on the same bucket, so the iterator order (output of keys, 275 # values, each) depends on the addition order in the hash. And locking 276 # the keys of the hash involves behind the scenes key additions. 277 is_deeply( [sort keys %target] , [sort keys %clean], 278 "list keys for $message"); 279 is_deeply( [sort values %target] , [sort values %clean], 280 "list values for $message"); 281 282 is_deeply( [sort %target] , [sort %clean], 283 "hash in list context for $message"); 284 285 my (@clean, @target); 286 while (my ($k, $v) = each %clean) { 287 push @clean, $k, $v; 288 } 289 while (my ($k, $v) = each %target) { 290 push @target, $k, $v; 291 } 292 293 is_deeply( [sort @target] , [sort @clean], 294 "iterating with each for $message"); 295 } 296 } 297} 298 299# Check clear works on locked empty hashes - SEGVs on 5.8.2. 300{ 301 my %hash; 302 lock_hash(%hash); 303 %hash = (); 304 ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); 305} 306{ 307 my %hash; 308 lock_keys(%hash); 309 %hash = (); 310 ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); 311} 312 313my $hash_seed = hash_seed(); 314ok($hash_seed >= 0, "hash_seed $hash_seed"); 315 316{ 317 package Minder; 318 my $counter; 319 sub DESTROY { 320 --$counter; 321 } 322 sub new { 323 ++$counter; 324 bless [], __PACKAGE__; 325 } 326 package main; 327 328 for my $state ('', 'locked') { 329 my $a = Minder->new(); 330 is ($counter, 1, "There is 1 object $state"); 331 my %hash; 332 $hash{a} = $a; 333 is ($counter, 1, "There is still 1 object $state"); 334 335 lock_keys(%hash) if $state; 336 337 is ($counter, 1, "There is still 1 object $state"); 338 undef $a; 339 is ($counter, 1, "Still 1 object $state"); 340 delete $hash{a}; 341 is ($counter, 0, "0 objects when hash key is deleted $state"); 342 $hash{a} = undef; 343 is ($counter, 0, "Still 0 objects $state"); 344 %hash = (); 345 is ($counter, 0, "0 objects after clear $state"); 346 } 347} 348{ 349 my %hash = map {$_,$_} qw(fwiffffff foosht teeoo); 350 lock_keys(%hash); 351 delete $hash{fwiffffff}; 352 is (scalar keys %hash, 2,"Count of keys after delete on locked hash"); 353 unlock_keys(%hash); 354 is (scalar keys %hash, 2,"Count of keys after unlock"); 355 356 my ($first, $value) = each %hash; 357 is ($hash{$first}, $value, "Key has the expected value before the lock"); 358 lock_keys(%hash); 359 is ($hash{$first}, $value, "Key has the expected value after the lock"); 360 361 my ($second, $v2) = each %hash; 362 363 is ($hash{$first}, $value, "Still correct after iterator advances"); 364 is ($hash{$second}, $v2, "Other key has the expected value"); 365} 366{ 367 my $x='foo'; 368 my %test; 369 hv_store(%test,'x',$x); 370 is($test{x},'foo','hv_store() stored'); 371 $test{x}='bar'; 372 is($x,'bar','hv_store() aliased'); 373 is($test{x},'bar','hv_store() aliased and stored'); 374} 375 376{ 377 my %hash=map { $_ => 1 } qw( a b c d e f); 378 delete $hash{c}; 379 lock_keys(%hash); 380 ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 1'); 381 delete @hash{qw(b e)}; 382 my @hidden=sort(hidden_keys(%hash)); 383 my @legal=sort(legal_keys(%hash)); 384 my @keys=sort(keys(%hash)); 385 #warn "@legal\n@keys\n"; 386 is("@hidden","b e",'lock_keys @hidden DDS/t'); 387 is("@legal","a b d e f",'lock_keys @legal DDS/t'); 388 is("@keys","a d f",'lock_keys @keys DDS/t'); 389} 390{ 391 my %hash=(0..9); 392 lock_keys(%hash); 393 ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 2'); 394 Hash::Util::unlock_keys(%hash); 395 ok(!Internals::SvREADONLY(%hash),'unlock_keys DDS/t 2'); 396} 397{ 398 my %hash=(0..9); 399 lock_keys(%hash,keys(%hash),'a'..'f'); 400 ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t'); 401 my @hidden=sort(hidden_keys(%hash)); 402 my @legal=sort(legal_keys(%hash)); 403 my @keys=sort(keys(%hash)); 404 is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3'); 405 is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3'); 406 is("@keys","0 2 4 6 8",'lock_keys() @keys'); 407} 408{ 409 my %hash=map { $_ => 1 } qw( a b c d e f); 410 delete $hash{c}; 411 lock_ref_keys(\%hash); 412 ok(Internals::SvREADONLY(%hash),'lock_ref_keys DDS/t'); 413 delete @hash{qw(b e)}; 414 my @hidden=sort(hidden_keys(%hash)); 415 my @legal=sort(legal_keys(%hash)); 416 my @keys=sort(keys(%hash)); 417 #warn "@legal\n@keys\n"; 418 is("@hidden","b e",'lock_ref_keys @hidden DDS/t 1'); 419 is("@legal","a b d e f",'lock_ref_keys @legal DDS/t 1'); 420 is("@keys","a d f",'lock_ref_keys @keys DDS/t 1'); 421} 422{ 423 my %hash=(0..9); 424 lock_ref_keys(\%hash,keys %hash,'a'..'f'); 425 ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t'); 426 my @hidden=sort(hidden_keys(%hash)); 427 my @legal=sort(legal_keys(%hash)); 428 my @keys=sort(keys(%hash)); 429 is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2'); 430 is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2'); 431 is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2'); 432} 433{ 434 my %hash=(0..9); 435 lock_ref_keys_plus(\%hash,'a'..'f'); 436 ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); 437 my @hidden=sort(hidden_keys(%hash)); 438 my @legal=sort(legal_keys(%hash)); 439 my @keys=sort(keys(%hash)); 440 is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t'); 441 is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t'); 442 is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t'); 443} 444{ 445 my %hash=(0..9); 446 lock_keys_plus(%hash,'a'..'f'); 447 ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t'); 448 my @hidden=sort(hidden_keys(%hash)); 449 my @legal=sort(legal_keys(%hash)); 450 my @keys=sort(keys(%hash)); 451 is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3'); 452 is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3'); 453 is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3'); 454} 455 456{ 457 my %hash = ('a'..'f'); 458 my @keys = (); 459 my @ph = (); 460 my @lock = ('a', 'c', 'e', 'g'); 461 lock_keys(%hash, @lock); 462 my $ref = all_keys(%hash, @keys, @ph); 463 my @crrack = sort(@keys); 464 my @ooooff = qw(a c e); 465 my @bam = qw(g); 466 467 ok(ref $ref eq ref \%hash && $ref == \%hash, 468 "all_keys() - \$ref is a reference to \%hash"); 469 is_deeply(\@crrack, \@ooooff, "Keys are what they should be"); 470 is_deeply(\@ph, \@bam, "Placeholders in place"); 471} 472 473