1#!/usr/bin/perl -Tw
2
3BEGIN {
4    if( $ENV{PERL_CORE} ) {
5        @INC = '../lib';
6        chdir 't';
7    }
8}
9use Test::More tests => 173;
10use strict;
11
12my @Exported_Funcs;
13BEGIN { 
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}
21foreach my $func (@Exported_Funcs) {
22    can_ok __PACKAGE__, $func;
23}
24
25my %hash = (foo => 42, bar => 23, locked => 'yep');
26lock_keys(%hash);
27eval { $hash{baz} = 99; };
28like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
29                                                       'lock_keys()');
30is( $hash{bar}, 23 );
31ok( !exists $hash{baz} );
32
33delete $hash{bar};
34ok( !exists $hash{bar} );
35$hash{bar} = 69;
36is( $hash{bar}, 69 );
37
38eval { () = $hash{i_dont_exist} };
39like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
40
41lock_value(%hash, 'locked');
42eval { print "# oops" if $hash{four} };
43like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
44
45eval { $hash{"\x{2323}"} = 3 };
46like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
47                                               'wide hex key' );
48
49eval { delete $hash{locked} };
50like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
51                                           'trying to delete a locked key' );
52eval { $hash{locked} = 42; };
53like( $@, qr/^Modification of a read-only value attempted/,
54                                           'trying to change a locked key' );
55is( $hash{locked}, 'yep' );
56
57eval { delete $hash{I_dont_exist} };
58like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
59                             'trying to delete a key that doesnt exist' );
60
61ok( !exists $hash{I_dont_exist} );
62
63unlock_keys(%hash);
64$hash{I_dont_exist} = 42;
65is( $hash{I_dont_exist}, 42,    'unlock_keys' );
66
67eval { $hash{locked} = 42; };
68like( $@, qr/^Modification of a read-only value attempted/,
69                             '  individual key still readonly' );
70eval { delete $hash{locked} },
71is( $@, '', '  but can be deleted :(' );
72
73unlock_value(%hash, 'locked');
74$hash{locked} = 42;
75is( $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
159lock_keys(%ENV);
160eval { () = $ENV{I_DONT_EXIST} };
161like( $@, 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# Check clear works on locked empty hashes - SEGVs on 5.8.2.
278{
279    my %hash;
280    lock_hash(%hash);
281    %hash = ();
282    ok(keys(%hash) == 0, 'clear empty lock_hash() hash');
283}
284{
285    my %hash;
286    lock_keys(%hash);
287    %hash = ();
288    ok(keys(%hash) == 0, 'clear empty lock_keys() hash');
289}
290
291my $hash_seed = hash_seed();
292ok($hash_seed >= 0, "hash_seed $hash_seed");
293
294{
295    package Minder;
296    my $counter;
297    sub DESTROY {
298	--$counter;
299    }
300    sub new {
301	++$counter;
302	bless [], __PACKAGE__;
303    }
304    package main;
305
306    for my $state ('', 'locked') {
307	my $a = Minder->new();
308	is ($counter, 1, "There is 1 object $state");
309	my %hash;
310	$hash{a} = $a;
311	is ($counter, 1, "There is still 1 object $state");
312
313	lock_keys(%hash) if $state;
314
315	is ($counter, 1, "There is still 1 object $state");
316	undef $a;
317	is ($counter, 1, "Still 1 object $state");
318	delete $hash{a};
319	is ($counter, 0, "0 objects when hash key is deleted $state");
320	$hash{a} = undef;
321	is ($counter, 0, "Still 0 objects $state");
322	%hash = ();
323	is ($counter, 0, "0 objects after clear $state");
324    }
325}
326