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