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 | } |
5f099cb0 |
9 | use Test::More tests => 159; |
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 |
9a7034eb |
17 | hash_seed |
49293501 |
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; }; |
2393f1b9 |
28 | like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, |
49293501 |
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} }; |
2393f1b9 |
39 | like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ ); |
49293501 |
40 | |
41 | lock_value(%hash, 'locked'); |
42 | eval { print "# oops" if $hash{four} }; |
2393f1b9 |
43 | like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ ); |
49293501 |
44 | |
45 | eval { $hash{"\x{2323}"} = 3 }; |
2393f1b9 |
46 | like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, |
49293501 |
47 | 'wide hex key' ); |
48 | |
49 | eval { delete $hash{locked} }; |
2393f1b9 |
50 | like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, |
49293501 |
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} }; |
2393f1b9 |
58 | like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, |
49293501 |
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 | |
34c3c4e3 |
78 | { |
49293501 |
79 | my %hash = ( foo => 42, locked => 23 ); |
80 | |
81 | lock_keys(%hash); |
49293501 |
82 | eval { %hash = ( wubble => 42 ) }; # we know this will bomb |
34c3c4e3 |
83 | like( $@, qr/^Attempt to access disallowed key 'wubble'/ ); |
49293501 |
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) }; |
34c3c4e3 |
93 | like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ ); |
49293501 |
94 | } |
95 | |
49293501 |
96 | { |
97 | my %hash = (KEY => 1, RO => 2); |
98 | lock_keys(%hash); |
99 | eval { %hash = (KEY => 1, RO => 2) }; |
34c3c4e3 |
100 | is( $@, ''); |
49293501 |
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 }; |
2393f1b9 |
112 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, |
49293501 |
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 }; |
2393f1b9 |
131 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' ); |
49293501 |
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 | |
29569577 |
147 | ok( Internals::SvREADONLY(%hash) ); |
148 | ok( Internals::SvREADONLY($hash{foo}) ); |
149 | ok( Internals::SvREADONLY($hash{bar}) ); |
49293501 |
150 | |
151 | unlock_hash ( %hash ); |
152 | |
29569577 |
153 | ok( !Internals::SvREADONLY(%hash) ); |
154 | ok( !Internals::SvREADONLY($hash{foo}) ); |
155 | ok( !Internals::SvREADONLY($hash{bar}) ); |
49293501 |
156 | } |
157 | |
158 | |
159 | lock_keys(%ENV); |
160 | eval { () = $ENV{I_DONT_EXIST} }; |
2393f1b9 |
161 | like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); |
dfd4ef2f |
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"); |
0cd24ecf |
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)"); |
dfd4ef2f |
219 | } |
015a5f36 |
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 | } |
c910b28a |
276 | |
5f099cb0 |
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 | |
9a7034eb |
291 | my $hash_seed = hash_seed(); |
292 | ok($hash_seed >= 0, "hash_seed $hash_seed"); |