lib/Hash/Util.t

   1 #!/usr/bin/perl -Tw
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         @INC = '../lib';
   6         chdir 't';
   7     }
   8 }
   9 use Test::More tests => 173;
  10 use strict;
  11
  12 my @Exported_Funcs;
  13 BEGIN {
  14     @Exported_Funcs = qw(lock_keys   unlock_keys
  15                          lock_value  unlock_value
  16                          lock_hash   unlock_hash
  17                          hash_seed
  18                         );
  19     use_ok 'Hash::Util', @Exported_Funcs;
  20 }
  21 foreach my $func (@Exported_Funcs) {
  22     can_ok __PACKAGE__, $func;
  23 }
  24
  25 my %hash = (foo => 42, bar => 23, locked => 'yep');
  26 lock_keys(%hash);
  27 eval { $hash{baz} = 99; };
  28 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
  29                                                        'lock_keys()');
  30 is( $hash{bar}, 23 );
  31 ok( !exists $hash{baz} );
  32
  33 delete $hash{bar};
  34 ok( !exists $hash{bar} );
  35 $hash{bar} = 69;
  36 is( $hash{bar}, 69 );
  37
  38 eval { () = $hash{i_dont_exist} };
  39 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
  40
  41 lock_value(%hash, 'locked');
  42 eval { print "# oops" if $hash{four} };
  43 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
  44
  45 eval { $hash{"\x{2323}"} = 3 };
  46 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
  47                                                'wide hex key' );
  48
  49 eval { delete $hash{locked} };
  50 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
  51                                            'trying to delete a locked key' );
  52 eval { $hash{locked} = 42; };
  53 like( $@, qr/^Modification of a read-only value attempted/,
  54                                            'trying to change a locked key' );
  55 is( $hash{locked}, 'yep' );
  56
  57 eval { delete $hash{I_dont_exist} };
  58 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
  59                              'trying to delete a key that doesnt exist' );
  60
  61 ok( !exists $hash{I_dont_exist} );
  62
  63 unlock_keys(%hash);
  64 $hash{I_dont_exist} = 42;
  65 is( $hash{I_dont_exist}, 42,    'unlock_keys' );
  66
  67 eval { $hash{locked} = 42; };
  68 like( $@, qr/^Modification of a read-only value attempted/,
  69                              '  individual key still readonly' );
  70 eval { delete $hash{locked} },
  71 is( $@, '', '  but can be deleted :(' );
  72
  73 unlock_value(%hash, 'locked');
  74 $hash{locked} = 42;
  75 is( $hash{locked}, 42,  'unlock_value' );
  76
  77
  78 {
  79     my %hash = ( foo => 42, locked => 23 );
  80
  81     lock_keys(%hash);
  82     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
  83     like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
  84     unlock_keys(%hash);
  85 }
  86
  87 {
  88     my %hash = (KEY => 'val', RO => 'val');
  89     lock_keys(%hash);
  90     lock_value(%hash, 'RO');
  91
  92     eval { %hash = (KEY => 1) };
  93     like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
  94 }
  95
  96 {
  97     my %hash = (KEY => 1, RO => 2);
  98     lock_keys(%hash);
  99     eval { %hash = (KEY => 1, RO => 2) };
 100     is( $@, '');
 101 }
 102
 103
 104
 105 {
 106     my %hash = ();
 107     lock_keys(%hash, qw(foo bar));
 108     is( keys %hash, 0,  'lock_keys() w/keyset shouldnt add new keys' );
 109     $hash{foo} = 42;
 110     is( keys %hash, 1 );
 111     eval { $hash{wibble} = 42 };
 112     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
 113                         '  locked');
 114
 115     unlock_keys(%hash);
 116     eval { $hash{wibble} = 23; };
 117     is( $@, '', 'unlock_keys' );
 118 }
 119
 120
 121 {
 122     my %hash = (foo => 42, bar => undef, baz => 0);
 123     lock_keys(%hash, qw(foo bar baz up down));
 124     is( keys %hash, 3,   'lock_keys() w/keyset didnt add new keys' );
 125     is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
 126
 127     eval { $hash{up} = 42; };
 128     is( $@, '' );
 129
 130     eval { $hash{wibble} = 23 };
 131     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, '  locked' );
 132 }
 133
 134
 135 {
 136     my %hash = (foo => 42, bar => undef);
 137     eval { lock_keys(%hash, qw(foo baz)); };
 138     is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
 139                     "set at %s line %d\n", __FILE__, __LINE__ - 2) );
 140 }
 141
 142
 143 {
 144     my %hash = (foo => 42, bar => 23);
 145     lock_hash( %hash );
 146
 147     ok( Internals::SvREADONLY(%hash) );
 148     ok( Internals::SvREADONLY($hash{foo}) );
 149     ok( Internals::SvREADONLY($hash{bar}) );
 150
 151     unlock_hash ( %hash );
 152
 153     ok( !Internals::SvREADONLY(%hash) );
 154     ok( !Internals::SvREADONLY($hash{foo}) );
 155     ok( !Internals::SvREADONLY($hash{bar}) );
 156 }
 157
 158
 159 lock_keys(%ENV);
 160 eval { () = $ENV{I_DONT_EXIST} };
 161 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,   'locked %ENV');
 162
 163 {
 164     my %hash;
 165
 166     lock_keys(%hash, 'first');
 167
 168     is (scalar keys %hash, 0, "place holder isn't a key");
 169     $hash{first} = 1;
 170     is (scalar keys %hash, 1, "we now have a key");
 171     delete $hash{first};
 172     is (scalar keys %hash, 0, "now no key");
 173
 174     unlock_keys(%hash);
 175
 176     $hash{interregnum} = 1.5;
 177     is (scalar keys %hash, 1, "key again");
 178     delete $hash{interregnum};
 179     is (scalar keys %hash, 0, "no key again");
 180
 181     lock_keys(%hash, 'second');
 182
 183     is (scalar keys %hash, 0, "place holder isn't a key");
 184
 185     eval {$hash{zeroeth} = 0};
 186     like ($@,
 187           qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
 188           'locked key never mentioned before should fail');
 189     eval {$hash{first} = -1};
 190     like ($@,
 191           qr/^Attempt to access disallowed key 'first' in a restricted hash/,
 192           'previously locked place holders should also fail');
 193     is (scalar keys %hash, 0, "and therefore there are no keys");
 194     $hash{second} = 1;
 195     is (scalar keys %hash, 1, "we now have just one key");
 196     delete $hash{second};
 197     is (scalar keys %hash, 0, "back to zero");
 198
 199     unlock_keys(%hash); # We have deliberately left a placeholder.
 200
 201     $hash{void} = undef;
 202     $hash{nowt} = undef;
 203
 204     is (scalar keys %hash, 2, "two keys, values both undef");
 205
 206     lock_keys(%hash);
 207
 208     is (scalar keys %hash, 2, "still two keys after locking");
 209
 210     eval {$hash{second} = -1};
 211     like ($@,
 212           qr/^Attempt to access disallowed key 'second' in a restricted hash/,
 213           'previously locked place holders should fail');
 214
 215     is ($hash{void}, undef,
 216         "undef values should not be misunderstood as placeholders");
 217     is ($hash{nowt}, undef,
 218         "undef values should not be misunderstood as placeholders (again)");
 219 }
 220
 221 {
 222   # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant
 223   # bug whereby hash iterators could lose hash keys (and values, as the code
 224   # is common) for restricted hashes.
 225
 226   my @keys = qw(small medium large);
 227
 228   # There should be no difference whether it is restricted or not
 229   foreach my $lock (0, 1) {
 230     # Try setting all combinations of the 3 keys
 231     foreach my $usekeys (0..7) {
 232       my @usekeys;
 233       for my $bits (0,1,2) {
 234         push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
 235       }
 236       my %clean = map {$_ => length $_} @usekeys;
 237       my %target;
 238       lock_keys ( %target, @keys ) if $lock;
 239
 240       while (my ($k, $v) = each %clean) {
 241         $target{$k} = $v;
 242       }
 243
 244       my $message
 245         = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
 246
 247       is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
 248       is (scalar values %target, scalar values %clean,
 249           "scalar values for $message");
 250       # Yes. All these sorts are necessary. Even for "identical hashes"
 251       # Because the data dependency of the test involves two of the strings
 252       # colliding on the same bucket, so the iterator order (output of keys,
 253       # values, each) depends on the addition order in the hash. And locking
 254       # the keys of the hash involves behind the scenes key additions.
 255       is_deeply( [sort keys %target] , [sort keys %clean],
 256                  "list keys for $message");
 257       is_deeply( [sort values %target] , [sort values %clean],
 258                  "list values for $message");
 259
 260       is_deeply( [sort %target] , [sort %clean],
 261                  "hash in list context for $message");
 262
 263       my (@clean, @target);
 264       while (my ($k, $v) = each %clean) {
 265         push @clean, $k, $v;
 266       }
 267       while (my ($k, $v) = each %target) {
 268         push @target, $k, $v;
 269       }
 270
 271       is_deeply( [sort @target] , [sort @clean],
 272                  "iterating with each for $message");
 273     }
 274   }
 275 }
 276
 277 # Check clear works on locked empty hashes - SEGVs on 5.8.2.
 278 {
 279     my %hash;
 280     lock_hash(%hash);
 281     %hash = ();
 282     ok(keys(%hash) == 0, 'clear empty lock_hash() hash');
 283 }
 284 {
 285     my %hash;
 286     lock_keys(%hash);
 287     %hash = ();
 288     ok(keys(%hash) == 0, 'clear empty lock_keys() hash');
 289 }
 290
 291 my $hash_seed = hash_seed();
 292 ok($hash_seed >= 0, "hash_seed $hash_seed");
 293
 294 {
 295     package Minder;
 296     my $counter;
 297     sub DESTROY {
 298         --$counter;
 299     }
 300     sub new {
 301         ++$counter;
 302         bless [], __PACKAGE__;
 303     }
 304     package main;
 305
 306     for my $state ('', 'locked') {
 307         my $a = Minder->new();
 308         is ($counter, 1, "There is 1 object $state");
 309         my %hash;
 310         $hash{a} = $a;
 311         is ($counter, 1, "There is still 1 object $state");
 312
 313         lock_keys(%hash) if $state;
 314
 315         is ($counter, 1, "There is still 1 object $state");
 316         undef $a;
 317         is ($counter, 1, "Still 1 object $state");
 318         delete $hash{a};
 319         is ($counter, 0, "0 objects when hash key is deleted $state");
 320         $hash{a} = undef;
 321         is ($counter, 0, "Still 0 objects $state");
 322         %hash = ();
 323         is ($counter, 0, "0 objects after clear $state");
 324     }
 325 }