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 | } |
e67b9e52 |
9 | use Test::More tests => 155; |
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 |
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 |
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 |
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 |
43 | |
44 | eval { $hash{"\x{2323}"} = 3 }; |
2393f1b9 |
45 | like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, |
49293501 |
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 |
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 |
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 |
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 |
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 |
93 | } |
94 | |
49293501 |
95 | { |
96 | my %hash = (KEY => 1, RO => 2); |
97 | lock_keys(%hash); |
98 | eval { %hash = (KEY => 1, RO => 2) }; |
34c3c4e3 |
99 | is( $@, ''); |
49293501 |
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 |
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 |
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 |
146 | ok( Internals::SvREADONLY(%hash) ); |
147 | ok( Internals::SvREADONLY($hash{foo}) ); |
148 | ok( Internals::SvREADONLY($hash{bar}) ); |
49293501 |
149 | |
150 | unlock_hash ( %hash ); |
151 | |
29569577 |
152 | ok( !Internals::SvREADONLY(%hash) ); |
153 | ok( !Internals::SvREADONLY($hash{foo}) ); |
154 | ok( !Internals::SvREADONLY($hash{bar}) ); |
49293501 |
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 |
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 |
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 |
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 | } |
c910b28a |
275 | |