Commit | Line | Data |
0314122a |
1 | #!perl -w |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS'; |
7 | require Config; import Config; |
8 | if ($Config{'extensions'} !~ /\bXS\/APItest\b/) { |
9 | # Look, I'm using this fully-qualified variable more than once! |
10 | my $arch = $MacPerl::Architecture; |
11 | print "1..0 # Skip: XS::APItest was not built\n"; |
12 | exit 0; |
13 | } |
14 | } |
15 | |
3128e575 |
16 | use strict; |
17 | use utf8; |
0314122a |
18 | use Tie::Hash; |
3128e575 |
19 | use Test::More 'no_plan'; |
20 | |
55289a74 |
21 | BEGIN {use_ok('XS::APItest')}; |
0314122a |
22 | |
3128e575 |
23 | sub preform_test; |
24 | sub test_present; |
25 | sub test_absent; |
26 | sub test_delete_present; |
27 | sub test_delete_absent; |
28 | sub brute_force_exists; |
29 | sub test_store; |
30 | sub test_fetch_present; |
31 | sub test_fetch_absent; |
0314122a |
32 | |
b60cf05a |
33 | my $utf8_for_258 = chr 258; |
34 | utf8::encode $utf8_for_258; |
0314122a |
35 | |
3128e575 |
36 | my @testkeys = ('N', chr 198, chr 256); |
b60cf05a |
37 | my @keys = (@testkeys, $utf8_for_258); |
0314122a |
38 | |
3128e575 |
39 | foreach (@keys) { |
40 | utf8::downgrade $_, 1; |
41 | } |
42 | main_tests (\@keys, \@testkeys, ''); |
0314122a |
43 | |
3128e575 |
44 | foreach (@keys) { |
45 | utf8::upgrade $_; |
46 | } |
47 | main_tests (\@keys, \@testkeys, ' [utf8 hash]'); |
0314122a |
48 | |
3128e575 |
49 | { |
50 | my %h = (a=>'cheat'); |
51 | tie %h, 'Tie::StdHash'; |
1baaf5d7 |
52 | is (XS::APItest::Hash::store(\%h, chr 258, 1), undef); |
3128e575 |
53 | |
54 | ok (!exists $h{$utf8_for_258}, |
55 | "hv_store doesn't insert a key with the raw utf8 on a tied hash"); |
56 | } |
0314122a |
57 | |
5d2b1485 |
58 | { |
59 | my $strtab = strtab(); |
60 | is (ref $strtab, 'HASH', "The shared string table quacks like a hash"); |
8ca60cef |
61 | my $wibble = "\0"; |
5d2b1485 |
62 | eval { |
8ca60cef |
63 | $strtab->{$wibble}++; |
5d2b1485 |
64 | }; |
65 | my $prefix = "Cannot modify shared string table in hv_"; |
66 | my $what = $prefix . 'fetch'; |
67 | like ($@, qr/^$what/,$what); |
68 | eval { |
69 | XS::APItest::Hash::store($strtab, 'Boom!', 1) |
70 | }; |
71 | $what = $prefix . 'store'; |
72 | like ($@, qr/^$what/, $what); |
73 | if (0) { |
74 | A::B->method(); |
75 | } |
76 | # DESTROY should be in there. |
77 | eval { |
78 | delete $strtab->{DESTROY}; |
79 | }; |
80 | $what = $prefix . 'delete'; |
81 | like ($@, qr/^$what/, $what); |
82 | # I can't work out how to get to the code that flips the wasutf8 flag on |
83 | # the hash key without some ikcy XS |
84 | } |
2dc92170 |
85 | |
86 | { |
87 | is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1], |
88 | "hv_free_ent frees the value immediately"); |
89 | is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1], |
90 | "hv_delayfree_ent keeps the value around until FREETMPS"); |
91 | } |
35ab5632 |
92 | |
93 | foreach my $in ("", "N", "a\0b") { |
94 | my $got = XS::APItest::Hash::test_share_unshare_pvn($in); |
95 | is ($got, $in, "test_share_unshare_pvn"); |
96 | } |
97 | |
55289a74 |
98 | if ($] > 5.009) { |
b54b4831 |
99 | my %hash; |
100 | XS::APItest::Hash::rot13_hash(\%hash); |
101 | $hash{a}++; @hash{qw(p i e)} = (2, 4, 8); |
102 | |
103 | my @keys = sort keys %hash; |
104 | is("@keys", join(' ', sort(rot13(qw(a p i e)))), |
105 | "uvar magic called exactly once on store"); |
106 | |
107 | is($hash{i}, 4); |
55289a74 |
108 | |
109 | is(delete $hash{a}, 1); |
110 | |
111 | is(keys %hash, 3); |
112 | @keys = sort keys %hash; |
113 | is("@keys", join(' ', sort(rot13(qw(p i e))))); |
114 | |
115 | is (XS::APItest::Hash::delete_ent (\%hash, 'p', |
116 | XS::APItest::HV_DISABLE_UVAR_XKEY), |
117 | undef, "Deleting a known key with conversion disabled fails (ent)"); |
118 | is(keys %hash, 3); |
119 | |
120 | is (XS::APItest::Hash::delete_ent (\%hash, 'p', 0), |
121 | 2, "Deleting a known key with conversion enabled works (ent)"); |
122 | is(keys %hash, 2); |
123 | @keys = sort keys %hash; |
124 | is("@keys", join(' ', sort(rot13(qw(i e))))); |
125 | |
126 | is (XS::APItest::Hash::delete (\%hash, 'i', |
127 | XS::APItest::HV_DISABLE_UVAR_XKEY), |
128 | undef, "Deleting a known key with conversion disabled fails"); |
129 | is(keys %hash, 2); |
130 | |
131 | is (XS::APItest::Hash::delete (\%hash, 'i', 0), |
132 | 4, "Deleting a known key with conversion enabled works"); |
133 | is(keys %hash, 1); |
134 | @keys = sort keys %hash; |
135 | is("@keys", join(' ', sort(rot13(qw(e))))); |
bdee33e4 |
136 | |
137 | $hash{f} = 9; |
138 | is(keys %hash, 2); |
139 | @keys = sort keys %hash; |
140 | is("@keys", join(' ', sort(rot13(qw(e f))))); |
141 | |
142 | is (XS::APItest::Hash::store_ent(\%hash, 'g', 10), 10, "store_ent"); |
143 | is(keys %hash, 3); |
144 | @keys = sort keys %hash; |
145 | is("@keys", join(' ', sort(rot13(qw(e f g))))); |
146 | |
147 | is (XS::APItest::Hash::store(\%hash, 'h', 11), 11, "store"); |
148 | is(keys %hash, 4); |
149 | @keys = sort keys %hash; |
150 | is("@keys", join(' ', sort(rot13(qw(e f g h))))); |
151 | |
152 | is (XS::APItest::Hash::fetch_ent(\%hash, 'g'), 10, "fetch_ent"); |
153 | is (XS::APItest::Hash::fetch_ent(\%hash, rot13('g')), undef, |
154 | "fetch_ent (missing)"); |
155 | |
156 | is (XS::APItest::Hash::fetch(\%hash, 'h'), 11, "fetch"); |
157 | is (XS::APItest::Hash::fetch(\%hash, rot13('h')), undef, |
158 | "fetch (missing)"); |
159 | |
160 | ok (XS::APItest::Hash::exists_ent(\%hash, 'e'), "exists_ent"); |
161 | ok (!XS::APItest::Hash::exists_ent(\%hash, rot13('e')), |
162 | "exists_ent (missing)"); |
163 | |
164 | ok (XS::APItest::Hash::exists(\%hash, 'f'), "exists"); |
165 | ok (!XS::APItest::Hash::exists(\%hash, rot13('f')), "exists (missing)"); |
b54b4831 |
166 | } |
167 | |
3128e575 |
168 | exit; |
0314122a |
169 | |
3128e575 |
170 | ################################ The End ################################ |
0314122a |
171 | |
3128e575 |
172 | sub main_tests { |
173 | my ($keys, $testkeys, $description) = @_; |
174 | foreach my $key (@$testkeys) { |
175 | my $lckey = ($key eq chr 198) ? chr 230 : lc $key; |
176 | my $unikey = $key; |
177 | utf8::encode $unikey; |
0314122a |
178 | |
3128e575 |
179 | utf8::downgrade $key, 1; |
180 | utf8::downgrade $lckey, 1; |
181 | utf8::downgrade $unikey, 1; |
182 | main_test_inner ($key, $lckey, $unikey, $keys, $description); |
0314122a |
183 | |
3128e575 |
184 | utf8::upgrade $key; |
185 | utf8::upgrade $lckey; |
186 | utf8::upgrade $unikey; |
187 | main_test_inner ($key, $lckey, $unikey, $keys, |
188 | $description . ' [key utf8 on]'); |
189 | } |
0314122a |
190 | |
3128e575 |
191 | # hv_exists was buggy for tied hashes, in that the raw utf8 key was being |
192 | # used - the utf8 flag was being lost. |
193 | perform_test (\&test_absent, (chr 258), $keys, ''); |
0314122a |
194 | |
3128e575 |
195 | perform_test (\&test_fetch_absent, (chr 258), $keys, ''); |
196 | perform_test (\&test_delete_absent, (chr 258), $keys, ''); |
0314122a |
197 | } |
198 | |
3128e575 |
199 | sub main_test_inner { |
200 | my ($key, $lckey, $unikey, $keys, $description) = @_; |
201 | perform_test (\&test_present, $key, $keys, $description); |
202 | perform_test (\&test_fetch_present, $key, $keys, $description); |
203 | perform_test (\&test_delete_present, $key, $keys, $description); |
b60cf05a |
204 | |
3128e575 |
205 | perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']); |
206 | perform_test (\&test_store, $key, $keys, $description, []); |
b60cf05a |
207 | |
3128e575 |
208 | perform_test (\&test_absent, $lckey, $keys, $description); |
209 | perform_test (\&test_fetch_absent, $lckey, $keys, $description); |
210 | perform_test (\&test_delete_absent, $lckey, $keys, $description); |
b60cf05a |
211 | |
3128e575 |
212 | return if $unikey eq $key; |
213 | |
214 | perform_test (\&test_absent, $unikey, $keys, $description); |
215 | perform_test (\&test_fetch_absent, $unikey, $keys, $description); |
216 | perform_test (\&test_delete_absent, $unikey, $keys, $description); |
b60cf05a |
217 | } |
218 | |
3128e575 |
219 | sub perform_test { |
220 | my ($test_sub, $key, $keys, $message, @other) = @_; |
b60cf05a |
221 | my $printable = join ',', map {ord} split //, $key; |
222 | |
3128e575 |
223 | my (%hash, %tiehash); |
224 | tie %tiehash, 'Tie::StdHash'; |
b60cf05a |
225 | |
3128e575 |
226 | @hash{@$keys} = @$keys; |
227 | @tiehash{@$keys} = @$keys; |
b60cf05a |
228 | |
3128e575 |
229 | &$test_sub (\%hash, $key, $printable, $message, @other); |
230 | &$test_sub (\%tiehash, $key, $printable, "$message tie", @other); |
b60cf05a |
231 | } |
232 | |
3128e575 |
233 | sub test_present { |
234 | my ($hash, $key, $printable, $message) = @_; |
235 | |
236 | ok (exists $hash->{$key}, "hv_exists_ent present$message $printable"); |
237 | ok (XS::APItest::Hash::exists ($hash, $key), |
238 | "hv_exists present$message $printable"); |
b60cf05a |
239 | } |
240 | |
3128e575 |
241 | sub test_absent { |
242 | my ($hash, $key, $printable, $message) = @_; |
858117f8 |
243 | |
3128e575 |
244 | ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable"); |
245 | ok (!XS::APItest::Hash::exists ($hash, $key), |
246 | "hv_exists absent$message $printable"); |
b60cf05a |
247 | } |
248 | |
3128e575 |
249 | sub test_delete_present { |
250 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
251 | |
3128e575 |
252 | my $copy = {}; |
253 | my $class = tied %$hash; |
254 | if (defined $class) { |
255 | tie %$copy, ref $class; |
256 | } |
257 | $copy = {%$hash}; |
8829b5e2 |
258 | ok (brute_force_exists ($copy, $key), |
259 | "hv_delete_ent present$message $printable"); |
3128e575 |
260 | is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable"); |
8829b5e2 |
261 | ok (!brute_force_exists ($copy, $key), |
262 | "hv_delete_ent present$message $printable"); |
3128e575 |
263 | $copy = {%$hash}; |
8829b5e2 |
264 | ok (brute_force_exists ($copy, $key), |
265 | "hv_delete present$message $printable"); |
3128e575 |
266 | is (XS::APItest::Hash::delete ($copy, $key), $key, |
267 | "hv_delete present$message $printable"); |
8829b5e2 |
268 | ok (!brute_force_exists ($copy, $key), |
269 | "hv_delete present$message $printable"); |
b60cf05a |
270 | } |
271 | |
3128e575 |
272 | sub test_delete_absent { |
273 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
274 | |
3128e575 |
275 | my $copy = {}; |
276 | my $class = tied %$hash; |
277 | if (defined $class) { |
278 | tie %$copy, ref $class; |
279 | } |
280 | $copy = {%$hash}; |
281 | is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable"); |
282 | $copy = {%$hash}; |
283 | is (XS::APItest::Hash::delete ($copy, $key), undef, |
284 | "hv_delete absent$message $printable"); |
b60cf05a |
285 | } |
286 | |
3128e575 |
287 | sub test_store { |
288 | my ($hash, $key, $printable, $message, $defaults) = @_; |
289 | my $HV_STORE_IS_CRAZY = 1; |
b60cf05a |
290 | |
3128e575 |
291 | # We are cheating - hv_store returns NULL for a store into an empty |
292 | # tied hash. This isn't helpful here. |
0314122a |
293 | |
3128e575 |
294 | my $class = tied %$hash; |
0314122a |
295 | |
3128e575 |
296 | my %h1 = @$defaults; |
297 | my %h2 = @$defaults; |
298 | if (defined $class) { |
299 | tie %h1, ref $class; |
300 | tie %h2, ref $class; |
1baaf5d7 |
301 | $HV_STORE_IS_CRAZY = undef; |
3128e575 |
302 | } |
1baaf5d7 |
303 | is (XS::APItest::Hash::store_ent(\%h1, $key, 1), $HV_STORE_IS_CRAZY, |
3128e575 |
304 | "hv_store_ent$message $printable"); |
305 | ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable"); |
306 | is (XS::APItest::Hash::store(\%h2, $key, 1), $HV_STORE_IS_CRAZY, |
307 | "hv_store$message $printable"); |
308 | ok (brute_force_exists (\%h2, $key), "hv_store$message $printable"); |
309 | } |
0314122a |
310 | |
3128e575 |
311 | sub test_fetch_present { |
312 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
313 | |
3128e575 |
314 | is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable"); |
315 | is (XS::APItest::Hash::fetch ($hash, $key), $key, |
316 | "hv_fetch present$message $printable"); |
0314122a |
317 | } |
318 | |
3128e575 |
319 | sub test_fetch_absent { |
320 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
321 | |
3128e575 |
322 | is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable"); |
323 | is (XS::APItest::Hash::fetch ($hash, $key), undef, |
324 | "hv_fetch absent$message $printable"); |
325 | } |
b60cf05a |
326 | |
3128e575 |
327 | sub brute_force_exists { |
328 | my ($hash, $key) = @_; |
329 | foreach (keys %$hash) { |
330 | return 1 if $key eq $_; |
331 | } |
332 | return 0; |
b60cf05a |
333 | } |
b54b4831 |
334 | |
335 | sub rot13 { |
336 | my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_; |
337 | wantarray ? @results : $results[0]; |
338 | } |