7 require Config; import Config;
8 keys %Config; # Silence warning
9 if ($Config{extensions} !~ /\bHash\/Util\b/) {
10 print "1..0 # Skip: Hash::Util was not built\n";
23 lock_value unlock_value
25 lock_keys_plus hash_locked
26 hidden_keys legal_keys
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
36 plan tests => 204 + @Exported_Funcs;
37 use_ok 'Hash::Util', @Exported_Funcs;
39 foreach my $func (@Exported_Funcs) {
40 can_ok __PACKAGE__, $func;
43 my %hash = (foo => 42, bar => 23, locked => 'yep');
45 eval { $hash{baz} = 99; };
46 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
49 ok( !exists $hash{baz},'!exists $hash{baz}' );
52 ok( !exists $hash{bar},'!exists $hash{bar}' );
54 is( $hash{bar}, 69 ,'$hash{bar} == 69');
56 eval { () = $hash{i_dont_exist} };
57 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/,
60 lock_value(%hash, 'locked');
61 eval { print "# oops" if $hash{four} };
62 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/,
65 eval { $hash{"\x{2323}"} = 3 };
66 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
69 eval { delete $hash{locked} };
70 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
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' );
77 eval { delete $hash{I_dont_exist} };
78 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
79 'trying to delete a key that doesnt exist' );
81 ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' );
84 $hash{I_dont_exist} = 42;
85 is( $hash{I_dont_exist}, 42, 'unlock_keys' );
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 :(' );
93 unlock_value(%hash, 'locked');
95 is( $hash{locked}, 42, 'unlock_value' );
99 my %hash = ( foo => 42, locked => 23 );
102 eval { %hash = ( wubble => 42 ) }; # we know this will bomb
103 like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' );
108 my %hash = (KEY => 'val', RO => 'val');
110 lock_value(%hash, 'RO');
112 eval { %hash = (KEY => 1) };
113 like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
117 my %hash = (KEY => 1, RO => 2);
119 eval { %hash = (KEY => 1, RO => 2) };
127 lock_keys(%hash, qw(foo bar));
128 is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
131 eval { $hash{wibble} = 42 };
132 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
133 'write threw error (locked)');
136 eval { $hash{wibble} = 23; };
137 is( $@, '', 'unlock_keys' );
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' );
145 is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 },'is_deeply' );
147 eval { $hash{up} = 42; };
148 is( $@, '','No error 1' );
150 eval { $hash{wibble} = 23 };
151 like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
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 ".
160 "set at %s line %d\n", __FILE__, __LINE__ - 2),
166 my %hash = (foo => 42, bar => 23);
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}' );
173 unlock_hash ( %hash );
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}' );
182 eval { () = $ENV{I_DONT_EXIST} };
183 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV');
188 lock_keys(%hash, 'first');
190 is (scalar keys %hash, 0, "place holder isn't a key");
192 is (scalar keys %hash, 1, "we now have a key");
194 is (scalar keys %hash, 0, "now no key");
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");
203 lock_keys(%hash, 'second');
205 is (scalar keys %hash, 0, "place holder isn't a key");
207 eval {$hash{zeroeth} = 0};
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};
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");
217 is (scalar keys %hash, 1, "we now have just one key");
218 delete $hash{second};
219 is (scalar keys %hash, 0, "back to zero");
221 unlock_keys(%hash); # We have deliberately left a placeholder.
226 is (scalar keys %hash, 2, "two keys, values both undef");
230 is (scalar keys %hash, 2, "still two keys after locking");
232 eval {$hash{second} = -1};
234 qr/^Attempt to access disallowed key 'second' in a restricted hash/,
235 'previously locked place holders should fail');
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)");
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.
248 my @keys = qw(small medium large);
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) {
255 for my $bits (0,1,2) {
256 push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
258 my %clean = map {$_ => length $_} @usekeys;
260 lock_keys ( %target, @keys ) if $lock;
262 while (my ($k, $v) = each %clean) {
267 = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
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");
282 is_deeply( [sort %target] , [sort %clean],
283 "hash in list context for $message");
285 my (@clean, @target);
286 while (my ($k, $v) = each %clean) {
289 while (my ($k, $v) = each %target) {
290 push @target, $k, $v;
293 is_deeply( [sort @target] , [sort @clean],
294 "iterating with each for $message");
299 # Check clear works on locked empty hashes - SEGVs on 5.8.2.
304 ok(keys(%hash) == 0, 'clear empty lock_hash() hash');
310 ok(keys(%hash) == 0, 'clear empty lock_keys() hash');
313 my $hash_seed = hash_seed();
314 ok($hash_seed >= 0, "hash_seed $hash_seed");
324 bless [], __PACKAGE__;
328 for my $state ('', 'locked') {
329 my $a = Minder->new();
330 is ($counter, 1, "There is 1 object $state");
333 is ($counter, 1, "There is still 1 object $state");
335 lock_keys(%hash) if $state;
337 is ($counter, 1, "There is still 1 object $state");
339 is ($counter, 1, "Still 1 object $state");
341 is ($counter, 0, "0 objects when hash key is deleted $state");
343 is ($counter, 0, "Still 0 objects $state");
345 is ($counter, 0, "0 objects after clear $state");
349 my %hash = map {$_,$_} qw(fwiffffff foosht teeoo);
351 delete $hash{fwiffffff};
352 is (scalar keys %hash, 2,"Count of keys after delete on locked hash");
354 is (scalar keys %hash, 2,"Count of keys after unlock");
356 my ($first, $value) = each %hash;
357 is ($hash{$first}, $value, "Key has the expected value before the lock");
359 is ($hash{$first}, $value, "Key has the expected value after the lock");
361 my ($second, $v2) = each %hash;
363 is ($hash{$first}, $value, "Still correct after iterator advances");
364 is ($hash{$second}, $v2, "Other key has the expected value");
369 hv_store(%test,'x',$x);
370 is($test{x},'foo','hv_store() stored');
372 is($x,'bar','hv_store() aliased');
373 is($test{x},'bar','hv_store() aliased and stored');
377 my %hash=map { $_ => 1 } qw( a b c d e f);
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');
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');
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');
409 my %hash=map { $_ => 1 } qw( a b c d e f);
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');
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');
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');
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');
457 my %hash = ('a'..'f');
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);
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");