This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ae5e7c940b98cf2d8143829f2a9310a8846d315f
[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 => 155;
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                         );
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; };
27 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
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} };
38 like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
39
40 lock_value(%hash, 'locked');
41 eval { print "# oops" if $hash{four} };
42 like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
43
44 eval { $hash{"\x{2323}"} = 3 };
45 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
46                                                'wide hex key' );
47
48 eval { delete $hash{locked} };
49 like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
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} };
57 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
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
77 {
78     my %hash = ( foo => 42, locked => 23 );
79
80     lock_keys(%hash);
81     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
82     like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
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) };
92     like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
93 }
94
95 {
96     my %hash = (KEY => 1, RO => 2);
97     lock_keys(%hash);
98     eval { %hash = (KEY => 1, RO => 2) };
99     is( $@, '');
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 };
111     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
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 };
130     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, '  locked' );
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
146     ok( Internals::SvREADONLY(%hash) );
147     ok( Internals::SvREADONLY($hash{foo}) );
148     ok( Internals::SvREADONLY($hash{bar}) );
149
150     unlock_hash ( %hash );
151
152     ok( !Internals::SvREADONLY(%hash) );
153     ok( !Internals::SvREADONLY($hash{foo}) );
154     ok( !Internals::SvREADONLY($hash{bar}) );
155 }
156
157
158 lock_keys(%ENV);
159 eval { () = $ENV{I_DONT_EXIST} };
160 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,   'locked %ENV');
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");
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)");
218 }
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 }