Commit | Line | Data |
49293501 |
1 | #!/usr/bin/perl -Tw |
2 | |
3 | BEGIN { |
4 | if( $ENV{PERL_CORE} ) { |
5 | @INC = '../lib'; |
6 | chdir 't'; |
7 | } |
8 | } |
015a5f36 |
9 | use Test::More tests => 157; |
0cd24ecf |
10 | use strict; |
49293501 |
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; }; |
2393f1b9 |
27 | like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, |
49293501 |
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} }; |
2393f1b9 |
38 | like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ ); |
49293501 |
39 | |
40 | lock_value(%hash, 'locked'); |
41 | eval { print "# oops" if $hash{four} }; |
2393f1b9 |
42 | like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ ); |
49293501 |
43 | |
44 | eval { $hash{"\x{2323}"} = 3 }; |
2393f1b9 |
45 | like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, |
49293501 |
46 | 'wide hex key' ); |
47 | |
48 | eval { delete $hash{locked} }; |
2393f1b9 |
49 | like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, |
49293501 |
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} }; |
2393f1b9 |
57 | like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, |
49293501 |
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 |
2393f1b9 |
85 | like( $@, qr/^Attempt to clear a restricted hash/ ); |
49293501 |
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) }; |
2393f1b9 |
101 | like( $@, qr/^Attempt to clear a restricted hash/ ); |
49293501 |
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) }; |
2393f1b9 |
110 | like( $@, qr/^Attempt to clear a restricted hash/ ); |
49293501 |
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 }; |
2393f1b9 |
122 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, |
49293501 |
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 }; |
2393f1b9 |
141 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' ); |
49293501 |
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 | |
29569577 |
157 | ok( Internals::SvREADONLY(%hash) ); |
158 | ok( Internals::SvREADONLY($hash{foo}) ); |
159 | ok( Internals::SvREADONLY($hash{bar}) ); |
49293501 |
160 | |
161 | unlock_hash ( %hash ); |
162 | |
29569577 |
163 | ok( !Internals::SvREADONLY(%hash) ); |
164 | ok( !Internals::SvREADONLY($hash{foo}) ); |
165 | ok( !Internals::SvREADONLY($hash{bar}) ); |
49293501 |
166 | } |
167 | |
168 | |
169 | lock_keys(%ENV); |
170 | eval { () = $ENV{I_DONT_EXIST} }; |
2393f1b9 |
171 | like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); |
dfd4ef2f |
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"); |
0cd24ecf |
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)"); |
dfd4ef2f |
229 | } |
015a5f36 |
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 | } |