ext/Hash-Util/t/Util.t

   1 #!/usr/bin/perl -Tw
   2
   3 BEGIN {
   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
  14 use strict;
  15 use Test::More;
  16 my @Exported_Funcs;
  17 BEGIN {
  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 }
  43 foreach my $func (@Exported_Funcs) {
  44     can_ok __PACKAGE__, $func;
  45 }
  46
  47 my %hash = (foo => 42, bar => 23, locked => 'yep');
  48 lock_keys(%hash);
  49 eval { $hash{baz} = 99; };
  50 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
  51                                                        'lock_keys()');
  52 is( $hash{bar}, 23, '$hash{bar} == 23' );
  53 ok( !exists $hash{baz},'!exists $hash{baz}' );
  54
  55 delete $hash{bar};
  56 ok( !exists $hash{bar},'!exists $hash{bar}' );
  57 $hash{bar} = 69;
  58 is( $hash{bar}, 69 ,'$hash{bar} == 69');
  59
  60 eval { () = $hash{i_dont_exist} };
  61 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/,
  62       'Disallowed 1' );
  63
  64 lock_value(%hash, 'locked');
  65 eval { print "# oops" if $hash{four} };
  66 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/,
  67       'Disallowed 2' );
  68
  69 eval { $hash{"\x{2323}"} = 3 };
  70 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
  71                                                'wide hex key' );
  72
  73 eval { delete $hash{locked} };
  74 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
  75                                            'trying to delete a locked key' );
  76 eval { $hash{locked} = 42; };
  77 like( $@, qr/^Modification of a read-only value attempted/,
  78                                            'trying to change a locked key' );
  79 is( $hash{locked}, 'yep', '$hash{locked} is yep' );
  80
  81 eval { delete $hash{I_dont_exist} };
  82 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
  83                              'trying to delete a key that doesnt exist' );
  84
  85 ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' );
  86
  87 unlock_keys(%hash);
  88 $hash{I_dont_exist} = 42;
  89 is( $hash{I_dont_exist}, 42,    'unlock_keys' );
  90
  91 eval { $hash{locked} = 42; };
  92 like( $@, qr/^Modification of a read-only value attempted/,
  93                              '  individual key still readonly' );
  94 eval { delete $hash{locked} },
  95 is( $@, '', '  but can be deleted :(' );
  96
  97 unlock_value(%hash, 'locked');
  98 $hash{locked} = 42;
  99 is( $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
 193 lock_keys(%ENV);
 194 eval { () = $ENV{I_DONT_EXIST} };
 195 like(
 196     $@,
 197     qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,
 198     'locked %ENV'
 199 );
 200 unlock_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
 342 my $hash_seed = hash_seed();
 343 ok(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 }