Commit | Line | Data |
49293501 |
1 | #!/usr/bin/perl -Tw |
2 | |
3 | BEGIN { |
3cd56e99 |
4 | if ($ENV{PERL_CORE}) { |
96c33d98 |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | require Config; import Config; |
8 | keys %Config; # Silence warning |
339873be |
9 | if ($Config{extensions} !~ /\bHash\/Util\b/) { |
10 | print "1..0 # Skip: Hash::Util was not built\n"; |
96c33d98 |
11 | exit 0; |
12 | } |
49293501 |
13 | } |
14 | } |
49293501 |
15 | |
96c33d98 |
16 | use strict; |
17 | use Test::More; |
49293501 |
18 | my @Exported_Funcs; |
96c33d98 |
19 | BEGIN { |
20 | @Exported_Funcs = qw( |
21 | hash_seed all_keys |
22 | lock_keys unlock_keys |
23 | lock_value unlock_value |
24 | lock_hash unlock_hash |
25 | lock_keys_plus hash_locked |
26 | hidden_keys legal_keys |
27 | |
28 | lock_ref_keys unlock_ref_keys |
29 | lock_ref_value unlock_ref_value |
30 | lock_hashref unlock_hashref |
31 | lock_ref_keys_plus hashref_locked |
32 | hidden_ref_keys legal_ref_keys |
33 | hv_store |
34 | |
35 | ); |
1b888f13 |
36 | plan tests => 204 + @Exported_Funcs; |
49293501 |
37 | use_ok 'Hash::Util', @Exported_Funcs; |
38 | } |
39 | foreach my $func (@Exported_Funcs) { |
40 | can_ok __PACKAGE__, $func; |
41 | } |
42 | |
43 | my %hash = (foo => 42, bar => 23, locked => 'yep'); |
44 | lock_keys(%hash); |
45 | eval { $hash{baz} = 99; }; |
2393f1b9 |
46 | like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, |
49293501 |
47 | 'lock_keys()'); |
48 | is( $hash{bar}, 23 ); |
96c33d98 |
49 | ok( !exists $hash{baz},'!exists $hash{baz}' ); |
49293501 |
50 | |
51 | delete $hash{bar}; |
96c33d98 |
52 | ok( !exists $hash{bar},'!exists $hash{bar}' ); |
49293501 |
53 | $hash{bar} = 69; |
96c33d98 |
54 | is( $hash{bar}, 69 ,'$hash{bar} == 69'); |
49293501 |
55 | |
56 | eval { () = $hash{i_dont_exist} }; |
96c33d98 |
57 | like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/, |
58 | 'Disallowed 1' ); |
49293501 |
59 | |
60 | lock_value(%hash, 'locked'); |
61 | eval { print "# oops" if $hash{four} }; |
96c33d98 |
62 | like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/, |
63 | 'Disallowed 2' ); |
49293501 |
64 | |
65 | eval { $hash{"\x{2323}"} = 3 }; |
2393f1b9 |
66 | like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, |
49293501 |
67 | 'wide hex key' ); |
68 | |
69 | eval { delete $hash{locked} }; |
2393f1b9 |
70 | like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, |
49293501 |
71 | 'trying to delete a locked key' ); |
72 | eval { $hash{locked} = 42; }; |
73 | like( $@, qr/^Modification of a read-only value attempted/, |
74 | 'trying to change a locked key' ); |
75 | is( $hash{locked}, 'yep' ); |
76 | |
77 | eval { delete $hash{I_dont_exist} }; |
2393f1b9 |
78 | like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, |
49293501 |
79 | 'trying to delete a key that doesnt exist' ); |
80 | |
96c33d98 |
81 | ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' ); |
49293501 |
82 | |
83 | unlock_keys(%hash); |
84 | $hash{I_dont_exist} = 42; |
85 | is( $hash{I_dont_exist}, 42, 'unlock_keys' ); |
86 | |
87 | eval { $hash{locked} = 42; }; |
88 | like( $@, qr/^Modification of a read-only value attempted/, |
89 | ' individual key still readonly' ); |
90 | eval { delete $hash{locked} }, |
91 | is( $@, '', ' but can be deleted :(' ); |
92 | |
93 | unlock_value(%hash, 'locked'); |
94 | $hash{locked} = 42; |
95 | is( $hash{locked}, 42, 'unlock_value' ); |
96 | |
97 | |
34c3c4e3 |
98 | { |
49293501 |
99 | my %hash = ( foo => 42, locked => 23 ); |
100 | |
101 | lock_keys(%hash); |
49293501 |
102 | eval { %hash = ( wubble => 42 ) }; # we know this will bomb |
96c33d98 |
103 | like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' ); |
49293501 |
104 | unlock_keys(%hash); |
105 | } |
106 | |
96c33d98 |
107 | { |
49293501 |
108 | my %hash = (KEY => 'val', RO => 'val'); |
109 | lock_keys(%hash); |
110 | lock_value(%hash, 'RO'); |
111 | |
112 | eval { %hash = (KEY => 1) }; |
34c3c4e3 |
113 | like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ ); |
49293501 |
114 | } |
115 | |
49293501 |
116 | { |
117 | my %hash = (KEY => 1, RO => 2); |
118 | lock_keys(%hash); |
119 | eval { %hash = (KEY => 1, RO => 2) }; |
34c3c4e3 |
120 | is( $@, ''); |
49293501 |
121 | } |
122 | |
123 | |
124 | |
125 | { |
126 | my %hash = (); |
127 | lock_keys(%hash, qw(foo bar)); |
128 | is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' ); |
129 | $hash{foo} = 42; |
130 | is( keys %hash, 1 ); |
131 | eval { $hash{wibble} = 42 }; |
2393f1b9 |
132 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, |
96c33d98 |
133 | 'write threw error (locked)'); |
49293501 |
134 | |
135 | unlock_keys(%hash); |
136 | eval { $hash{wibble} = 23; }; |
137 | is( $@, '', 'unlock_keys' ); |
138 | } |
139 | |
140 | |
141 | { |
142 | my %hash = (foo => 42, bar => undef, baz => 0); |
143 | lock_keys(%hash, qw(foo bar baz up down)); |
144 | is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' ); |
96c33d98 |
145 | is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 },'is_deeply' ); |
49293501 |
146 | |
147 | eval { $hash{up} = 42; }; |
96c33d98 |
148 | is( $@, '','No error 1' ); |
49293501 |
149 | |
150 | eval { $hash{wibble} = 23 }; |
96c33d98 |
151 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, |
152 | 'locked "wibble"' ); |
49293501 |
153 | } |
154 | |
155 | |
156 | { |
157 | my %hash = (foo => 42, bar => undef); |
158 | eval { lock_keys(%hash, qw(foo baz)); }; |
159 | is( $@, sprintf("Hash has key 'bar' which is not in the new key ". |
96c33d98 |
160 | "set at %s line %d\n", __FILE__, __LINE__ - 2), |
161 | 'carp test' ); |
49293501 |
162 | } |
163 | |
164 | |
165 | { |
166 | my %hash = (foo => 42, bar => 23); |
167 | lock_hash( %hash ); |
168 | |
96c33d98 |
169 | ok( Internals::SvREADONLY(%hash),'Was locked %hash' ); |
170 | ok( Internals::SvREADONLY($hash{foo}),'Was locked $hash{foo}' ); |
171 | ok( Internals::SvREADONLY($hash{bar}),'Was locked $hash{bar}' ); |
49293501 |
172 | |
173 | unlock_hash ( %hash ); |
174 | |
96c33d98 |
175 | ok( !Internals::SvREADONLY(%hash),'Was unlocked %hash' ); |
176 | ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' ); |
177 | ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' ); |
49293501 |
178 | } |
179 | |
180 | |
181 | lock_keys(%ENV); |
182 | eval { () = $ENV{I_DONT_EXIST} }; |
2393f1b9 |
183 | like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); |
dfd4ef2f |
184 | |
185 | { |
186 | my %hash; |
187 | |
188 | lock_keys(%hash, 'first'); |
189 | |
190 | is (scalar keys %hash, 0, "place holder isn't a key"); |
191 | $hash{first} = 1; |
192 | is (scalar keys %hash, 1, "we now have a key"); |
193 | delete $hash{first}; |
194 | is (scalar keys %hash, 0, "now no key"); |
195 | |
196 | unlock_keys(%hash); |
197 | |
198 | $hash{interregnum} = 1.5; |
199 | is (scalar keys %hash, 1, "key again"); |
200 | delete $hash{interregnum}; |
201 | is (scalar keys %hash, 0, "no key again"); |
202 | |
203 | lock_keys(%hash, 'second'); |
204 | |
205 | is (scalar keys %hash, 0, "place holder isn't a key"); |
206 | |
207 | eval {$hash{zeroeth} = 0}; |
208 | like ($@, |
209 | qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, |
210 | 'locked key never mentioned before should fail'); |
211 | eval {$hash{first} = -1}; |
212 | like ($@, |
213 | qr/^Attempt to access disallowed key 'first' in a restricted hash/, |
214 | 'previously locked place holders should also fail'); |
215 | is (scalar keys %hash, 0, "and therefore there are no keys"); |
216 | $hash{second} = 1; |
217 | is (scalar keys %hash, 1, "we now have just one key"); |
0cd24ecf |
218 | delete $hash{second}; |
219 | is (scalar keys %hash, 0, "back to zero"); |
220 | |
221 | unlock_keys(%hash); # We have deliberately left a placeholder. |
222 | |
223 | $hash{void} = undef; |
224 | $hash{nowt} = undef; |
225 | |
226 | is (scalar keys %hash, 2, "two keys, values both undef"); |
227 | |
228 | lock_keys(%hash); |
229 | |
230 | is (scalar keys %hash, 2, "still two keys after locking"); |
231 | |
232 | eval {$hash{second} = -1}; |
233 | like ($@, |
234 | qr/^Attempt to access disallowed key 'second' in a restricted hash/, |
235 | 'previously locked place holders should fail'); |
236 | |
237 | is ($hash{void}, undef, |
238 | "undef values should not be misunderstood as placeholders"); |
239 | is ($hash{nowt}, undef, |
240 | "undef values should not be misunderstood as placeholders (again)"); |
dfd4ef2f |
241 | } |
015a5f36 |
242 | |
243 | { |
244 | # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant |
245 | # bug whereby hash iterators could lose hash keys (and values, as the code |
246 | # is common) for restricted hashes. |
247 | |
248 | my @keys = qw(small medium large); |
249 | |
250 | # There should be no difference whether it is restricted or not |
251 | foreach my $lock (0, 1) { |
252 | # Try setting all combinations of the 3 keys |
253 | foreach my $usekeys (0..7) { |
254 | my @usekeys; |
255 | for my $bits (0,1,2) { |
256 | push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); |
257 | } |
258 | my %clean = map {$_ => length $_} @usekeys; |
259 | my %target; |
260 | lock_keys ( %target, @keys ) if $lock; |
261 | |
262 | while (my ($k, $v) = each %clean) { |
263 | $target{$k} = $v; |
264 | } |
265 | |
266 | my $message |
267 | = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; |
268 | |
269 | is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); |
270 | is (scalar values %target, scalar values %clean, |
271 | "scalar values for $message"); |
272 | # Yes. All these sorts are necessary. Even for "identical hashes" |
273 | # Because the data dependency of the test involves two of the strings |
274 | # colliding on the same bucket, so the iterator order (output of keys, |
275 | # values, each) depends on the addition order in the hash. And locking |
276 | # the keys of the hash involves behind the scenes key additions. |
277 | is_deeply( [sort keys %target] , [sort keys %clean], |
278 | "list keys for $message"); |
279 | is_deeply( [sort values %target] , [sort values %clean], |
280 | "list values for $message"); |
281 | |
282 | is_deeply( [sort %target] , [sort %clean], |
283 | "hash in list context for $message"); |
284 | |
285 | my (@clean, @target); |
286 | while (my ($k, $v) = each %clean) { |
287 | push @clean, $k, $v; |
288 | } |
289 | while (my ($k, $v) = each %target) { |
290 | push @target, $k, $v; |
291 | } |
292 | |
293 | is_deeply( [sort @target] , [sort @clean], |
294 | "iterating with each for $message"); |
295 | } |
296 | } |
297 | } |
c910b28a |
298 | |
5f099cb0 |
299 | # Check clear works on locked empty hashes - SEGVs on 5.8.2. |
300 | { |
301 | my %hash; |
302 | lock_hash(%hash); |
303 | %hash = (); |
304 | ok(keys(%hash) == 0, 'clear empty lock_hash() hash'); |
305 | } |
306 | { |
307 | my %hash; |
308 | lock_keys(%hash); |
309 | %hash = (); |
310 | ok(keys(%hash) == 0, 'clear empty lock_keys() hash'); |
311 | } |
312 | |
9a7034eb |
313 | my $hash_seed = hash_seed(); |
314 | ok($hash_seed >= 0, "hash_seed $hash_seed"); |
754604c4 |
315 | |
316 | { |
317 | package Minder; |
318 | my $counter; |
319 | sub DESTROY { |
320 | --$counter; |
321 | } |
322 | sub new { |
323 | ++$counter; |
324 | bless [], __PACKAGE__; |
325 | } |
326 | package main; |
327 | |
328 | for my $state ('', 'locked') { |
329 | my $a = Minder->new(); |
330 | is ($counter, 1, "There is 1 object $state"); |
331 | my %hash; |
332 | $hash{a} = $a; |
333 | is ($counter, 1, "There is still 1 object $state"); |
334 | |
335 | lock_keys(%hash) if $state; |
336 | |
337 | is ($counter, 1, "There is still 1 object $state"); |
338 | undef $a; |
339 | is ($counter, 1, "Still 1 object $state"); |
340 | delete $hash{a}; |
341 | is ($counter, 0, "0 objects when hash key is deleted $state"); |
342 | $hash{a} = undef; |
343 | is ($counter, 0, "Still 0 objects $state"); |
344 | %hash = (); |
345 | is ($counter, 0, "0 objects after clear $state"); |
346 | } |
347 | } |
2e58978b |
348 | { |
349 | my %hash = map {$_,$_} qw(fwiffffff foosht teeoo); |
350 | lock_keys(%hash); |
351 | delete $hash{fwiffffff}; |
96c33d98 |
352 | is (scalar keys %hash, 2,"Count of keys after delete on locked hash"); |
2e58978b |
353 | unlock_keys(%hash); |
96c33d98 |
354 | is (scalar keys %hash, 2,"Count of keys after unlock"); |
2e58978b |
355 | |
356 | my ($first, $value) = each %hash; |
357 | is ($hash{$first}, $value, "Key has the expected value before the lock"); |
358 | lock_keys(%hash); |
359 | is ($hash{$first}, $value, "Key has the expected value after the lock"); |
360 | |
361 | my ($second, $v2) = each %hash; |
362 | |
363 | is ($hash{$first}, $value, "Still correct after iterator advances"); |
364 | is ($hash{$second}, $v2, "Other key has the expected value"); |
365 | } |
96c33d98 |
366 | { |
367 | my $x='foo'; |
368 | my %test; |
369 | hv_store(%test,'x',$x); |
370 | is($test{x},'foo','hv_store() stored'); |
371 | $test{x}='bar'; |
372 | is($x,'bar','hv_store() aliased'); |
373 | is($test{x},'bar','hv_store() aliased and stored'); |
374 | } |
375 | |
376 | { |
377 | my %hash=map { $_ => 1 } qw( a b c d e f); |
378 | delete $hash{c}; |
379 | lock_keys(%hash); |
380 | ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 1'); |
381 | delete @hash{qw(b e)}; |
382 | my @hidden=sort(hidden_keys(%hash)); |
383 | my @legal=sort(legal_keys(%hash)); |
384 | my @keys=sort(keys(%hash)); |
385 | #warn "@legal\n@keys\n"; |
386 | is("@hidden","b e",'lock_keys @hidden DDS/t'); |
387 | is("@legal","a b d e f",'lock_keys @legal DDS/t'); |
388 | is("@keys","a d f",'lock_keys @keys DDS/t'); |
389 | } |
390 | { |
391 | my %hash=(0..9); |
392 | lock_keys(%hash); |
393 | ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 2'); |
394 | Hash::Util::unlock_keys(%hash); |
395 | ok(!Internals::SvREADONLY(%hash),'unlock_keys DDS/t 2'); |
396 | } |
397 | { |
398 | my %hash=(0..9); |
399 | lock_keys(%hash,keys(%hash),'a'..'f'); |
400 | ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t'); |
401 | my @hidden=sort(hidden_keys(%hash)); |
402 | my @legal=sort(legal_keys(%hash)); |
403 | my @keys=sort(keys(%hash)); |
404 | is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3'); |
405 | is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3'); |
406 | is("@keys","0 2 4 6 8",'lock_keys() @keys'); |
407 | } |
408 | { |
409 | my %hash=map { $_ => 1 } qw( a b c d e f); |
410 | delete $hash{c}; |
411 | lock_ref_keys(\%hash); |
412 | ok(Internals::SvREADONLY(%hash),'lock_ref_keys DDS/t'); |
413 | delete @hash{qw(b e)}; |
414 | my @hidden=sort(hidden_keys(%hash)); |
415 | my @legal=sort(legal_keys(%hash)); |
416 | my @keys=sort(keys(%hash)); |
417 | #warn "@legal\n@keys\n"; |
418 | is("@hidden","b e",'lock_ref_keys @hidden DDS/t 1'); |
419 | is("@legal","a b d e f",'lock_ref_keys @legal DDS/t 1'); |
420 | is("@keys","a d f",'lock_ref_keys @keys DDS/t 1'); |
421 | } |
422 | { |
423 | my %hash=(0..9); |
424 | lock_ref_keys(\%hash,keys %hash,'a'..'f'); |
425 | ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t'); |
426 | my @hidden=sort(hidden_keys(%hash)); |
427 | my @legal=sort(legal_keys(%hash)); |
428 | my @keys=sort(keys(%hash)); |
429 | is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2'); |
430 | is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2'); |
431 | is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2'); |
432 | } |
433 | { |
434 | my %hash=(0..9); |
435 | lock_ref_keys_plus(\%hash,'a'..'f'); |
436 | ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); |
437 | my @hidden=sort(hidden_keys(%hash)); |
438 | my @legal=sort(legal_keys(%hash)); |
439 | my @keys=sort(keys(%hash)); |
440 | is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t'); |
441 | is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t'); |
442 | is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t'); |
443 | } |
444 | { |
445 | my %hash=(0..9); |
446 | lock_keys_plus(%hash,'a'..'f'); |
447 | ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t'); |
448 | my @hidden=sort(hidden_keys(%hash)); |
449 | my @legal=sort(legal_keys(%hash)); |
450 | my @keys=sort(keys(%hash)); |
451 | is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3'); |
452 | is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3'); |
453 | is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3'); |
454 | } |
1b888f13 |
455 | |
456 | { |
457 | my %hash = ('a'..'f'); |
458 | my @keys = (); |
459 | my @ph = (); |
460 | my @lock = ('a', 'c', 'e', 'g'); |
461 | lock_keys(%hash, @lock); |
462 | my $ref = all_keys(%hash, @keys, @ph); |
463 | my @crrack = sort(@keys); |
464 | my @ooooff = qw(a c e); |
465 | my @bam = qw(g); |
466 | |
467 | ok(ref $ref eq ref \%hash && $ref == \%hash, |
468 | "all_keys() - \$ref is a reference to \%hash"); |
469 | is_deeply(\@crrack, \@ooooff, "Keys are what they should be"); |
470 | is_deeply(\@ph, \@bam, "Placeholders in place"); |
471 | } |
472 | |