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 => 45;
  10
  11 my @Exported_Funcs;
  12 BEGIN {
  13     @Exported_Funcs = qw(lock_keys   unlock_keys
  14                          lock_value  unlock_value
  15                          lock_hash   unlock_hash
  16                         );
  17     use_ok 'Hash::Util', @Exported_Funcs;
  18 }
  19 foreach my $func (@Exported_Funcs) {
  20     can_ok __PACKAGE__, $func;
  21 }
  22
  23 my %hash = (foo => 42, bar => 23, locked => 'yep');
  24 lock_keys(%hash);
  25 eval { $hash{baz} = 99; };
  26 like( $@, qr/^Attempt to access disallowed key 'baz' in a fixed hash/,
  27                                                        'lock_keys()');
  28 is( $hash{bar}, 23 );
  29 ok( !exists $hash{baz} );
  30
  31 delete $hash{bar};
  32 ok( !exists $hash{bar} );
  33 $hash{bar} = 69;
  34 is( $hash{bar}, 69 );
  35
  36 eval { () = $hash{i_dont_exist} };
  37 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a fixed hash/ );
  38
  39 lock_value(%hash, 'locked');
  40 eval { print "# oops" if $hash{four} };
  41 like( $@, qr/^Attempt to access disallowed key 'four' in a fixed hash/ );
  42
  43 eval { $hash{"\x{2323}"} = 3 };
  44 like( $@, qr/^Attempt to access disallowed key '(.*)' in a fixed hash/,
  45                                                'wide hex key' );
  46
  47 eval { delete $hash{locked} };
  48 like( $@, qr/^Attempt to delete readonly key 'locked' from a fixed hash/,
  49                                            'trying to delete a locked key' );
  50 eval { $hash{locked} = 42; };
  51 like( $@, qr/^Modification of a read-only value attempted/,
  52                                            'trying to change a locked key' );
  53 is( $hash{locked}, 'yep' );
  54
  55 eval { delete $hash{I_dont_exist} };
  56 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a fixed hash/,
  57                              'trying to delete a key that doesnt exist' );
  58
  59 ok( !exists $hash{I_dont_exist} );
  60
  61 unlock_keys(%hash);
  62 $hash{I_dont_exist} = 42;
  63 is( $hash{I_dont_exist}, 42,    'unlock_keys' );
  64
  65 eval { $hash{locked} = 42; };
  66 like( $@, qr/^Modification of a read-only value attempted/,
  67                              '  individual key still readonly' );
  68 eval { delete $hash{locked} },
  69 is( $@, '', '  but can be deleted :(' );
  70
  71 unlock_value(%hash, 'locked');
  72 $hash{locked} = 42;
  73 is( $hash{locked}, 42,  'unlock_value' );
  74
  75
  76 TODO: {
  77 #    local $TODO = 'assigning to a hash screws with locked keys';
  78
  79     my %hash = ( foo => 42, locked => 23 );
  80
  81     lock_keys(%hash);
  82     lock_value(%hash, 'locked');
  83     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
  84     like( $@, qr/^Attempt to clear a fixed hash/ );
  85
  86     eval { unlock_value(%hash, 'locked') }; # but this shouldn't
  87     is( $@, '', 'unlock_value() after denied assignment' );
  88
  89     is_deeply( \%hash, { foo => 42, locked => 23 },
  90                       'hash should not be altered by denied assignment' );
  91     unlock_keys(%hash);
  92 }
  93
  94 {
  95     my %hash = (KEY => 'val', RO => 'val');
  96     lock_keys(%hash);
  97     lock_value(%hash, 'RO');
  98
  99     eval { %hash = (KEY => 1) };
 100     like( $@, qr/^Attempt to clear a fixed hash/ );
 101 }
 102
 103 # TODO:  This should be allowed but it might require putting extra
 104 #        code into aassign.
 105 {
 106     my %hash = (KEY => 1, RO => 2);
 107     lock_keys(%hash);
 108     eval { %hash = (KEY => 1, RO => 2) };
 109     like( $@, qr/^Attempt to clear a fixed hash/ );
 110 }
 111
 112
 113
 114 {
 115     my %hash = ();
 116     lock_keys(%hash, qw(foo bar));
 117     is( keys %hash, 0,  'lock_keys() w/keyset shouldnt add new keys' );
 118     $hash{foo} = 42;
 119     is( keys %hash, 1 );
 120     eval { $hash{wibble} = 42 };
 121     like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/,
 122                         '  locked');
 123
 124     unlock_keys(%hash);
 125     eval { $hash{wibble} = 23; };
 126     is( $@, '', 'unlock_keys' );
 127 }
 128
 129
 130 {
 131     my %hash = (foo => 42, bar => undef, baz => 0);
 132     lock_keys(%hash, qw(foo bar baz up down));
 133     is( keys %hash, 3,   'lock_keys() w/keyset didnt add new keys' );
 134     is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
 135
 136     eval { $hash{up} = 42; };
 137     is( $@, '' );
 138
 139     eval { $hash{wibble} = 23 };
 140     like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/, '  locked' );
 141 }
 142
 143
 144 {
 145     my %hash = (foo => 42, bar => undef);
 146     eval { lock_keys(%hash, qw(foo baz)); };
 147     is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
 148                     "set at %s line %d\n", __FILE__, __LINE__ - 2) );
 149 }
 150
 151
 152 {
 153     my %hash = (foo => 42, bar => 23);
 154     lock_hash( %hash );
 155
 156     ok( Internals::SvREADONLY(%hash) );
 157     ok( Internals::SvREADONLY($hash{foo}) );
 158     ok( Internals::SvREADONLY($hash{bar}) );
 159
 160     unlock_hash ( %hash );
 161
 162     ok( !Internals::SvREADONLY(%hash) );
 163     ok( !Internals::SvREADONLY($hash{foo}) );
 164     ok( !Internals::SvREADONLY($hash{bar}) );
 165 }
 166
 167
 168 lock_keys(%ENV);
 169 eval { () = $ENV{I_DONT_EXIST} };
 170 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a fixed hash/,   'locked %ENV');