4 if( $ENV{PERL_CORE} ) {
9 use Test::More tests => 45;
13 @Exported_Funcs = qw(lock_keys unlock_keys
14 lock_value unlock_value
17 use_ok 'Hash::Util', @Exported_Funcs;
19 foreach my $func (@Exported_Funcs) {
20 can_ok __PACKAGE__, $func;
23 my %hash = (foo => 42, bar => 23, locked => 'yep');
25 eval { $hash{baz} = 99; };
26 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
29 ok( !exists $hash{baz} );
32 ok( !exists $hash{bar} );
36 eval { () = $hash{i_dont_exist} };
37 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
39 lock_value(%hash, 'locked');
40 eval { print "# oops" if $hash{four} };
41 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
43 eval { $hash{"\x{2323}"} = 3 };
44 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
47 eval { delete $hash{locked} };
48 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted 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' );
55 eval { delete $hash{I_dont_exist} };
56 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
57 'trying to delete a key that doesnt exist' );
59 ok( !exists $hash{I_dont_exist} );
62 $hash{I_dont_exist} = 42;
63 is( $hash{I_dont_exist}, 42, 'unlock_keys' );
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 :(' );
71 unlock_value(%hash, 'locked');
73 is( $hash{locked}, 42, 'unlock_value' );
77 # local $TODO = 'assigning to a hash screws with locked keys';
79 my %hash = ( foo => 42, locked => 23 );
82 lock_value(%hash, 'locked');
83 eval { %hash = ( wubble => 42 ) }; # we know this will bomb
84 like( $@, qr/^Attempt to clear a restricted hash/ );
86 eval { unlock_value(%hash, 'locked') }; # but this shouldn't
87 is( $@, '', 'unlock_value() after denied assignment' );
89 is_deeply( \%hash, { foo => 42, locked => 23 },
90 'hash should not be altered by denied assignment' );
95 my %hash = (KEY => 'val', RO => 'val');
97 lock_value(%hash, 'RO');
99 eval { %hash = (KEY => 1) };
100 like( $@, qr/^Attempt to clear a restricted hash/ );
103 # TODO: This should be allowed but it might require putting extra
106 my %hash = (KEY => 1, RO => 2);
108 eval { %hash = (KEY => 1, RO => 2) };
109 like( $@, qr/^Attempt to clear a restricted hash/ );
116 lock_keys(%hash, qw(foo bar));
117 is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
120 eval { $hash{wibble} = 42 };
121 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
125 eval { $hash{wibble} = 23; };
126 is( $@, '', 'unlock_keys' );
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 } );
136 eval { $hash{up} = 42; };
139 eval { $hash{wibble} = 23 };
140 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' );
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) );
153 my %hash = (foo => 42, bar => 23);
156 ok( Internals::SvREADONLY(%hash) );
157 ok( Internals::SvREADONLY($hash{foo}) );
158 ok( Internals::SvREADONLY($hash{bar}) );
160 unlock_hash ( %hash );
162 ok( !Internals::SvREADONLY(%hash) );
163 ok( !Internals::SvREADONLY($hash{foo}) );
164 ok( !Internals::SvREADONLY($hash{bar}) );
169 eval { () = $ENV{I_DONT_EXIST} };
170 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV');