ext/Hash/Util/t/Util.t

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