This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Hash::Util::hash_seed() which answers among
[perl5.git] / lib / Hash / Util.t
1 #!/usr/bin/perl -Tw
2
3 BEGIN {
4     if( $ENV{PERL_CORE} ) {
5         @INC = '../lib';
6         chdir 't';
7     }
8 }
9 use Test::More tests => 157;
10 use strict;
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                          hash_seed
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; };
28 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
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} };
39 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
40
41 lock_value(%hash, 'locked');
42 eval { print "# oops" if $hash{four} };
43 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
44
45 eval { $hash{"\x{2323}"} = 3 };
46 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
47                                                'wide hex key' );
48
49 eval { delete $hash{locked} };
50 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
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} };
58 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
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
78 {
79     my %hash = ( foo => 42, locked => 23 );
80
81     lock_keys(%hash);
82     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
83     like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
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) };
93     like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
94 }
95
96 {
97     my %hash = (KEY => 1, RO => 2);
98     lock_keys(%hash);
99     eval { %hash = (KEY => 1, RO => 2) };
100     is( $@, '');
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 };
112     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
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 };
131     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, '  locked' );
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
147     ok( Internals::SvREADONLY(%hash) );
148     ok( Internals::SvREADONLY($hash{foo}) );
149     ok( Internals::SvREADONLY($hash{bar}) );
150
151     unlock_hash ( %hash );
152
153     ok( !Internals::SvREADONLY(%hash) );
154     ok( !Internals::SvREADONLY($hash{foo}) );
155     ok( !Internals::SvREADONLY($hash{bar}) );
156 }
157
158
159 lock_keys(%ENV);
160 eval { () = $ENV{I_DONT_EXIST} };
161 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,   'locked %ENV');
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");
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)");
219 }
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 }
276
277 my $hash_seed = hash_seed();
278 ok($hash_seed >= 0, "hash_seed $hash_seed");