Commit | Line | Data |
---|---|---|
49293501 MS |
1 | #!/usr/bin/perl -Tw |
2 | ||
3 | BEGIN { | |
4 | if( $ENV{PERL_CORE} ) { | |
5 | @INC = '../lib'; | |
6 | chdir 't'; | |
7 | } | |
8 | } | |
34c3c4e3 | 9 | use Test::More tests => 155; |
0cd24ecf | 10 | use strict; |
49293501 MS |
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 MS |
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 MS |
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 MS |
43 | |
44 | eval { $hash{"\x{2323}"} = 3 }; | |
2393f1b9 | 45 | like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, |
49293501 MS |
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 MS |
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 MS |
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 | ||
34c3c4e3 | 77 | { |
49293501 MS |
78 | my %hash = ( foo => 42, locked => 23 ); |
79 | ||
80 | lock_keys(%hash); | |
49293501 | 81 | eval { %hash = ( wubble => 42 ) }; # we know this will bomb |
34c3c4e3 | 82 | like( $@, qr/^Attempt to access disallowed key 'wubble'/ ); |
49293501 MS |
83 | unlock_keys(%hash); |
84 | } | |
85 | ||
86 | { | |
87 | my %hash = (KEY => 'val', RO => 'val'); | |
88 | lock_keys(%hash); | |
89 | lock_value(%hash, 'RO'); | |
90 | ||
91 | eval { %hash = (KEY => 1) }; | |
34c3c4e3 | 92 | like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ ); |
49293501 MS |
93 | } |
94 | ||
49293501 MS |
95 | { |
96 | my %hash = (KEY => 1, RO => 2); | |
97 | lock_keys(%hash); | |
98 | eval { %hash = (KEY => 1, RO => 2) }; | |
34c3c4e3 | 99 | is( $@, ''); |
49293501 MS |
100 | } |
101 | ||
102 | ||
103 | ||
104 | { | |
105 | my %hash = (); | |
106 | lock_keys(%hash, qw(foo bar)); | |
107 | is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' ); | |
108 | $hash{foo} = 42; | |
109 | is( keys %hash, 1 ); | |
110 | eval { $hash{wibble} = 42 }; | |
2393f1b9 | 111 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, |
49293501 MS |
112 | ' locked'); |
113 | ||
114 | unlock_keys(%hash); | |
115 | eval { $hash{wibble} = 23; }; | |
116 | is( $@, '', 'unlock_keys' ); | |
117 | } | |
118 | ||
119 | ||
120 | { | |
121 | my %hash = (foo => 42, bar => undef, baz => 0); | |
122 | lock_keys(%hash, qw(foo bar baz up down)); | |
123 | is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' ); | |
124 | is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } ); | |
125 | ||
126 | eval { $hash{up} = 42; }; | |
127 | is( $@, '' ); | |
128 | ||
129 | eval { $hash{wibble} = 23 }; | |
2393f1b9 | 130 | like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' ); |
49293501 MS |
131 | } |
132 | ||
133 | ||
134 | { | |
135 | my %hash = (foo => 42, bar => undef); | |
136 | eval { lock_keys(%hash, qw(foo baz)); }; | |
137 | is( $@, sprintf("Hash has key 'bar' which is not in the new key ". | |
138 | "set at %s line %d\n", __FILE__, __LINE__ - 2) ); | |
139 | } | |
140 | ||
141 | ||
142 | { | |
143 | my %hash = (foo => 42, bar => 23); | |
144 | lock_hash( %hash ); | |
145 | ||
29569577 JH |
146 | ok( Internals::SvREADONLY(%hash) ); |
147 | ok( Internals::SvREADONLY($hash{foo}) ); | |
148 | ok( Internals::SvREADONLY($hash{bar}) ); | |
49293501 MS |
149 | |
150 | unlock_hash ( %hash ); | |
151 | ||
29569577 JH |
152 | ok( !Internals::SvREADONLY(%hash) ); |
153 | ok( !Internals::SvREADONLY($hash{foo}) ); | |
154 | ok( !Internals::SvREADONLY($hash{bar}) ); | |
49293501 MS |
155 | } |
156 | ||
157 | ||
158 | lock_keys(%ENV); | |
159 | eval { () = $ENV{I_DONT_EXIST} }; | |
2393f1b9 | 160 | like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); |
dfd4ef2f NC |
161 | |
162 | { | |
163 | my %hash; | |
164 | ||
165 | lock_keys(%hash, 'first'); | |
166 | ||
167 | is (scalar keys %hash, 0, "place holder isn't a key"); | |
168 | $hash{first} = 1; | |
169 | is (scalar keys %hash, 1, "we now have a key"); | |
170 | delete $hash{first}; | |
171 | is (scalar keys %hash, 0, "now no key"); | |
172 | ||
173 | unlock_keys(%hash); | |
174 | ||
175 | $hash{interregnum} = 1.5; | |
176 | is (scalar keys %hash, 1, "key again"); | |
177 | delete $hash{interregnum}; | |
178 | is (scalar keys %hash, 0, "no key again"); | |
179 | ||
180 | lock_keys(%hash, 'second'); | |
181 | ||
182 | is (scalar keys %hash, 0, "place holder isn't a key"); | |
183 | ||
184 | eval {$hash{zeroeth} = 0}; | |
185 | like ($@, | |
186 | qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/, | |
187 | 'locked key never mentioned before should fail'); | |
188 | eval {$hash{first} = -1}; | |
189 | like ($@, | |
190 | qr/^Attempt to access disallowed key 'first' in a restricted hash/, | |
191 | 'previously locked place holders should also fail'); | |
192 | is (scalar keys %hash, 0, "and therefore there are no keys"); | |
193 | $hash{second} = 1; | |
194 | is (scalar keys %hash, 1, "we now have just one key"); | |
0cd24ecf NC |
195 | delete $hash{second}; |
196 | is (scalar keys %hash, 0, "back to zero"); | |
197 | ||
198 | unlock_keys(%hash); # We have deliberately left a placeholder. | |
199 | ||
200 | $hash{void} = undef; | |
201 | $hash{nowt} = undef; | |
202 | ||
203 | is (scalar keys %hash, 2, "two keys, values both undef"); | |
204 | ||
205 | lock_keys(%hash); | |
206 | ||
207 | is (scalar keys %hash, 2, "still two keys after locking"); | |
208 | ||
209 | eval {$hash{second} = -1}; | |
210 | like ($@, | |
211 | qr/^Attempt to access disallowed key 'second' in a restricted hash/, | |
212 | 'previously locked place holders should fail'); | |
213 | ||
214 | is ($hash{void}, undef, | |
215 | "undef values should not be misunderstood as placeholders"); | |
216 | is ($hash{nowt}, undef, | |
217 | "undef values should not be misunderstood as placeholders (again)"); | |
dfd4ef2f | 218 | } |
015a5f36 NC |
219 | |
220 | { | |
221 | # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant | |
222 | # bug whereby hash iterators could lose hash keys (and values, as the code | |
223 | # is common) for restricted hashes. | |
224 | ||
225 | my @keys = qw(small medium large); | |
226 | ||
227 | # There should be no difference whether it is restricted or not | |
228 | foreach my $lock (0, 1) { | |
229 | # Try setting all combinations of the 3 keys | |
230 | foreach my $usekeys (0..7) { | |
231 | my @usekeys; | |
232 | for my $bits (0,1,2) { | |
233 | push @usekeys, $keys[$bits] if $usekeys & (1 << $bits); | |
234 | } | |
235 | my %clean = map {$_ => length $_} @usekeys; | |
236 | my %target; | |
237 | lock_keys ( %target, @keys ) if $lock; | |
238 | ||
239 | while (my ($k, $v) = each %clean) { | |
240 | $target{$k} = $v; | |
241 | } | |
242 | ||
243 | my $message | |
244 | = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys; | |
245 | ||
246 | is (scalar keys %target, scalar keys %clean, "scalar keys for $message"); | |
247 | is (scalar values %target, scalar values %clean, | |
248 | "scalar values for $message"); | |
249 | # Yes. All these sorts are necessary. Even for "identical hashes" | |
250 | # Because the data dependency of the test involves two of the strings | |
251 | # colliding on the same bucket, so the iterator order (output of keys, | |
252 | # values, each) depends on the addition order in the hash. And locking | |
253 | # the keys of the hash involves behind the scenes key additions. | |
254 | is_deeply( [sort keys %target] , [sort keys %clean], | |
255 | "list keys for $message"); | |
256 | is_deeply( [sort values %target] , [sort values %clean], | |
257 | "list values for $message"); | |
258 | ||
259 | is_deeply( [sort %target] , [sort %clean], | |
260 | "hash in list context for $message"); | |
261 | ||
262 | my (@clean, @target); | |
263 | while (my ($k, $v) = each %clean) { | |
264 | push @clean, $k, $v; | |
265 | } | |
266 | while (my ($k, $v) = each %target) { | |
267 | push @target, $k, $v; | |
268 | } | |
269 | ||
270 | is_deeply( [sort @target] , [sort @clean], | |
271 | "iterating with each for $message"); | |
272 | } | |
273 | } | |
274 | } |