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 => 236 + @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); 200unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise 201 202{ 203 my %hash; 204 205 lock_keys(%hash, 'first'); 206 207 is (scalar keys %hash, 0, "place holder isn't a key"); 208 $hash{first} = 1; 209 is (scalar keys %hash, 1, "we now have a key"); 210 delete $hash{first}; 211 is (scalar keys %hash, 0, "now no key"); 212 213 unlock_keys(%hash); 214 215 $hash{interregnum} = 1.5; 216 is (scalar keys %hash, 1, "key again"); 217 delete $hash{interregnum}; 218 is (scalar keys %hash, 0, "no key again"); 219 220 lock_keys(%hash, 'second'); 221 222 is (scalar keys %hash, 0, "place holder isn't a key"); 223 224 eval {$hash{zeroeth} = 0}; 225 like ($@, 226 qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, 227 'locked key never mentioned before should fail'); 228 eval {$hash{first} = -1}; 229 like ($@, 230 qr/^Attempt to access disallowed key 'first' in a restricted hash/, 231 'previously locked place holders should also fail'); 232 is (scalar keys %hash, 0, "and therefore there are no keys"); 233 $hash{second} = 1; 234 is (scalar keys %hash, 1, "we now have just one key"); 235 delete $hash{second}; 236 is (scalar keys %hash, 0, "back to zero"); 237 238 unlock_keys(%hash); # We have deliberately left a placeholder. 239 240 $hash{void} = undef; 241 $hash{nowt} = undef; 242 243 is (scalar keys %hash, 2, "two keys, values both undef"); 244 245 lock_keys(%hash); 246 247 is (scalar keys %hash, 2, "still two keys after locking"); 248 249 eval {$hash{second} = -1}; 250 like ($@, 251 qr/^Attempt to access disallowed key 'second' in a restricted hash/, 252 'previously locked place holders should fail'); 253 254 is ($hash{void}, undef, 255 "undef values should not be misunderstood as placeholders"); 256 is ($hash{nowt}, undef, 257 "undef values should not be misunderstood as placeholders (again)"); 258} 259 260{ 261 # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant 262 # bug whereby hash iterators could lose hash keys (and values, as the code 263 # is common) for restricted hashes. 264 265 my @keys = qw(small medium large); 266 267 # There should be no difference whether it is restricted or not 268 foreach my $lock (0, 1) { 269 # Try setting all combinations of the 3 keys 270 foreach my $usekeys (0..7) { 271 my @usekeys; 272 for my $bits (0,1,2) { 273 push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); 274 } 275 my %clean = map {$_ => length $_} @usekeys; 276 my %target; 277 lock_keys ( %target, @keys ) if $lock; 278 279 while (my ($k, $v) = each %clean) { 280 $target{$k} = $v; 281 } 282 283 my $message 284 = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; 285 286 is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); 287 is (scalar values %target, scalar values %clean, 288 "scalar values for $message"); 289 # Yes. All these sorts are necessary. Even for "identical hashes" 290 # Because the data dependency of the test involves two of the strings 291 # colliding on the same bucket, so the iterator order (output of keys, 292 # values, each) depends on the addition order in the hash. And locking 293 # the keys of the hash involves behind the scenes key additions. 294 is_deeply( [sort keys %target] , [sort keys %clean], 295 "list keys for $message"); 296 is_deeply( [sort values %target] , [sort values %clean], 297 "list values for $message"); 298 299 is_deeply( [sort %target] , [sort %clean], 300 "hash in list context for $message"); 301 302 my (@clean, @target); 303 while (my ($k, $v) = each %clean) { 304 push @clean, $k, $v; 305 } 306 while (my ($k, $v) = each %target) { 307 push @target, $k, $v; 308 } 309 310 is_deeply( [sort @target] , [sort @clean], 311 "iterating with each for $message"); 312 } 313 } 314} 315 316# Check clear works on locked empty hashes - SEGVs on 5.8.2. 317{ 318 my %hash; 319 lock_hash(%hash); 320 %hash = (); 321 ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); 322} 323{ 324 my %hash; 325 lock_keys(%hash); 326 %hash = (); 327 ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); 328} 329 330# Copy-on-write scalars should not be deletable after lock_hash; 331{ 332 my %hash = (key=>__PACKAGE__); 333 lock_hash(%hash); 334 eval { delete $hash{key} }; 335 like $@, qr/^Attempt to delete readonly key /, 336 'COW scalars are not exempt from lock_hash (delete)'; 337 eval { %hash = () }; 338 like $@, qr/^Attempt to delete readonly key /, 339 'COW scalars are not exempt from lock_hash (clear)'; 340} 341 342my $hash_seed = hash_seed(); 343ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); 344 345{ 346 package Minder; 347 my $counter; 348 sub DESTROY { 349 --$counter; 350 } 351 sub new { 352 ++$counter; 353 bless [], __PACKAGE__; 354 } 355 package main; 356 357 for my $state ('', 'locked') { 358 my $a = Minder->new(); 359 is ($counter, 1, "There is 1 object $state"); 360 my %hash; 361 $hash{a} = $a; 362 is ($counter, 1, "There is still 1 object $state"); 363 364 lock_keys(%hash) if $state; 365 366 is ($counter, 1, "There is still 1 object $state"); 367 undef $a; 368 is ($counter, 1, "Still 1 object $state"); 369 delete $hash{a}; 370 is ($counter, 0, "0 objects when hash key is deleted $state"); 371 $hash{a} = undef; 372 is ($counter, 0, "Still 0 objects $state"); 373 %hash = (); 374 is ($counter, 0, "0 objects after clear $state"); 375 } 376} 377{ 378 my %hash = map {$_,$_} qw(fwiffffff foosht teeoo); 379 lock_keys(%hash); 380 delete $hash{fwiffffff}; 381 is (scalar keys %hash, 2,"Count of keys after delete on locked hash"); 382 unlock_keys(%hash); 383 is (scalar keys %hash, 2,"Count of keys after unlock"); 384 385 my ($first, $value) = each %hash; 386 is ($hash{$first}, $value, "Key has the expected value before the lock"); 387 lock_keys(%hash); 388 is ($hash{$first}, $value, "Key has the expected value after the lock"); 389 390 my ($second, $v2) = each %hash; 391 392 is ($hash{$first}, $value, "Still correct after iterator advances"); 393 is ($hash{$second}, $v2, "Other key has the expected value"); 394} 395{ 396 my $x='foo'; 397 my %test; 398 hv_store(%test,'x',$x); 399 is($test{x},'foo','hv_store() stored'); 400 $test{x}='bar'; 401 is($x,'bar','hv_store() aliased'); 402 is($test{x},'bar','hv_store() aliased and stored'); 403} 404 405{ 406 my %hash=map { $_ => 1 } qw( a b c d e f); 407 delete $hash{c}; 408 lock_keys(%hash); 409 ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 1'); 410 delete @hash{qw(b e)}; 411 my @hidden=sort(hidden_keys(%hash)); 412 my @legal=sort(legal_keys(%hash)); 413 my @keys=sort(keys(%hash)); 414 #warn "@legal\n@keys\n"; 415 is("@hidden","b e",'lock_keys @hidden DDS/t'); 416 is("@legal","a b d e f",'lock_keys @legal DDS/t'); 417 is("@keys","a d f",'lock_keys @keys DDS/t'); 418} 419{ 420 my %hash=(0..9); 421 lock_keys(%hash); 422 ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 2'); 423 Hash::Util::unlock_keys(%hash); 424 ok(!Internals::SvREADONLY(%hash),'unlock_keys DDS/t 2'); 425} 426{ 427 my %hash=(0..9); 428 lock_keys(%hash,keys(%hash),'a'..'f'); 429 ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t'); 430 my @hidden=sort(hidden_keys(%hash)); 431 my @legal=sort(legal_keys(%hash)); 432 my @keys=sort(keys(%hash)); 433 is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3'); 434 is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3'); 435 is("@keys","0 2 4 6 8",'lock_keys() @keys'); 436} 437{ 438 my %hash=map { $_ => 1 } qw( a b c d e f); 439 delete $hash{c}; 440 lock_ref_keys(\%hash); 441 ok(Internals::SvREADONLY(%hash),'lock_ref_keys DDS/t'); 442 delete @hash{qw(b e)}; 443 my @hidden=sort(hidden_keys(%hash)); 444 my @legal=sort(legal_keys(%hash)); 445 my @keys=sort(keys(%hash)); 446 #warn "@legal\n@keys\n"; 447 is("@hidden","b e",'lock_ref_keys @hidden DDS/t 1'); 448 is("@legal","a b d e f",'lock_ref_keys @legal DDS/t 1'); 449 is("@keys","a d f",'lock_ref_keys @keys DDS/t 1'); 450} 451{ 452 my %hash=(0..9); 453 lock_ref_keys(\%hash,keys %hash,'a'..'f'); 454 ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t'); 455 my @hidden=sort(hidden_keys(%hash)); 456 my @legal=sort(legal_keys(%hash)); 457 my @keys=sort(keys(%hash)); 458 is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2'); 459 is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2'); 460 is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2'); 461} 462{ 463 my %hash=(0..9); 464 lock_ref_keys_plus(\%hash,'a'..'f'); 465 ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); 466 my @hidden=sort(hidden_keys(%hash)); 467 my @legal=sort(legal_keys(%hash)); 468 my @keys=sort(keys(%hash)); 469 is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t'); 470 is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t'); 471 is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t'); 472} 473{ 474 my %hash=(0..9, 'a' => 'alpha'); 475 lock_ref_keys_plus(\%hash,'a'..'f'); 476 ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args overlap'); 477 my @hidden=sort(hidden_keys(%hash)); 478 my @legal=sort(legal_keys(%hash)); 479 my @keys=sort(keys(%hash)); 480 is("@hidden","b c d e f",'lock_ref_keys_plus() @hidden overlap'); 481 is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal overlap'); 482 is("@keys","0 2 4 6 8 a",'lock_ref_keys_plus() @keys overlap'); 483} 484{ 485 my %hash=(0..9); 486 lock_keys_plus(%hash,'a'..'f'); 487 ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t'); 488 my @hidden=sort(hidden_keys(%hash)); 489 my @legal=sort(legal_keys(%hash)); 490 my @keys=sort(keys(%hash)); 491 is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3'); 492 is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3'); 493 is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3'); 494} 495{ 496 my %hash=(0..9, 'a' => 'alpha'); 497 lock_keys_plus(%hash,'a'..'f'); 498 ok(Internals::SvREADONLY(%hash),'lock_keys_plus args overlap non-ref'); 499 my @hidden=sort(hidden_keys(%hash)); 500 my @legal=sort(legal_keys(%hash)); 501 my @keys=sort(keys(%hash)); 502 is("@hidden","b c d e f",'lock_keys_plus() @hidden overlap non-ref'); 503 is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal overlap non-ref'); 504 is("@keys","0 2 4 6 8 a",'lock_keys_plus() @keys overlap non-ref'); 505} 506 507{ 508 my %hash = ('a'..'f'); 509 my @keys = (); 510 my @ph = (); 511 my @lock = ('a', 'c', 'e', 'g'); 512 lock_keys(%hash, @lock); 513 my $ref = all_keys(%hash, @keys, @ph); 514 my @crrack = sort(@keys); 515 my @ooooff = qw(a c e); 516 my @bam = qw(g); 517 518 ok(ref $ref eq ref \%hash && $ref == \%hash, 519 "all_keys() - \$ref is a reference to \%hash"); 520 is_deeply(\@crrack, \@ooooff, "Keys are what they should be"); 521 is_deeply(\@ph, \@bam, "Placeholders in place"); 522} 523 524{ 525 my %hash = ( 526 a => 'alpha', 527 b => [ qw( beta gamma delta ) ], 528 c => [ 'epsilon', { zeta => 'eta' }, ], 529 d => { theta => 'iota' }, 530 ); 531 lock_hash_recurse(%hash); 532 ok( hash_locked(%hash), 533 "lock_hash_recurse(): top-level hash locked" ); 534 ok( hash_locked(%{$hash{d}}), 535 "lock_hash_recurse(): element which is hashref locked" ); 536 ok( ! hash_locked(%{$hash{c}[1]}), 537 "lock_hash_recurse(): element which is hashref in array ref not locked" ); 538 539 unlock_hash_recurse(%hash); 540 ok( hash_unlocked(%hash), 541 "unlock_hash_recurse(): top-level hash unlocked" ); 542 ok( hash_unlocked(%{$hash{d}}), 543 "unlock_hash_recurse(): element which is hashref unlocked" ); 544 ok( hash_unlocked(%{$hash{c}[1]}), 545 "unlock_hash_recurse(): element which is hashref in array ref not locked" ); 546} 547 548{ 549 my $h1= hash_value("foo"); 550 my $h2= hash_value("bar"); 551 is( $h1, hash_value("foo") ); 552 is( $h2, hash_value("bar") ); 553} 554{ 555 my @info1= bucket_info({}); 556 my @info2= bucket_info({1..10}); 557 my @stats1= bucket_stats({}); 558 my @stats2= bucket_stats({1..10}); 559 my $array1= bucket_array({}); 560 my $array2= bucket_array({1..10}); 561 is("@info1","0 8 0"); 562 is("@info2[0,1]","5 8"); 563 is("@stats1","0 8 0"); 564 is("@stats2[0,1]","5 8"); 565 my @keys1= sort map { ref $_ ? @$_ : () } @$array1; 566 my @keys2= sort map { ref $_ ? @$_ : () } @$array2; 567 is("@keys1",""); 568 is("@keys2","1 3 5 7 9"); 569} 570