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