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