This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mro UTF8 cleanup.
[perl5.git] / ext / XS-APItest / t / hash.t
CommitLineData
0314122a
NC
1#!perl -w
2
3128e575
NC
3use strict;
4use utf8;
0314122a 5use Tie::Hash;
3a0e665e 6use Test::More;
3128e575 7
55289a74 8BEGIN {use_ok('XS::APItest')};
0314122a 9
3128e575
NC
10sub preform_test;
11sub test_present;
12sub test_absent;
13sub test_delete_present;
14sub test_delete_absent;
15sub brute_force_exists;
16sub test_store;
17sub test_fetch_present;
18sub test_fetch_absent;
0314122a 19
b60cf05a
NC
20my $utf8_for_258 = chr 258;
21utf8::encode $utf8_for_258;
0314122a 22
3128e575 23my @testkeys = ('N', chr 198, chr 256);
b60cf05a 24my @keys = (@testkeys, $utf8_for_258);
0314122a 25
3128e575
NC
26foreach (@keys) {
27 utf8::downgrade $_, 1;
28}
29main_tests (\@keys, \@testkeys, '');
0314122a 30
3128e575
NC
31foreach (@keys) {
32 utf8::upgrade $_;
33}
34main_tests (\@keys, \@testkeys, ' [utf8 hash]');
0314122a 35
3128e575
NC
36{
37 my %h = (a=>'cheat');
38 tie %h, 'Tie::StdHash';
9568a123
NC
39 # is bug 36327 fixed?
40 my $result = ($] > 5.009) ? undef : 1;
41
42 is (XS::APItest::Hash::store(\%h, chr 258, 1), $result);
3a0e665e 43
3128e575
NC
44 ok (!exists $h{$utf8_for_258},
45 "hv_store doesn't insert a key with the raw utf8 on a tied hash");
46}
0314122a 47
3a0e665e 48{
5d2b1485
NC
49 my $strtab = strtab();
50 is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
8ca60cef 51 my $wibble = "\0";
5d2b1485 52 eval {
8ca60cef 53 $strtab->{$wibble}++;
5d2b1485
NC
54 };
55 my $prefix = "Cannot modify shared string table in hv_";
56 my $what = $prefix . 'fetch';
57 like ($@, qr/^$what/,$what);
58 eval {
59 XS::APItest::Hash::store($strtab, 'Boom!', 1)
60 };
61 $what = $prefix . 'store';
62 like ($@, qr/^$what/, $what);
63 if (0) {
64 A::B->method();
65 }
66 # DESTROY should be in there.
67 eval {
68 delete $strtab->{DESTROY};
69 };
70 $what = $prefix . 'delete';
71 like ($@, qr/^$what/, $what);
72 # I can't work out how to get to the code that flips the wasutf8 flag on
73 # the hash key without some ikcy XS
74}
2dc92170
NC
75
76{
77 is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
78 "hv_free_ent frees the value immediately");
79 is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
80 "hv_delayfree_ent keeps the value around until FREETMPS");
81}
35ab5632
NC
82
83foreach my $in ("", "N", "a\0b") {
84 my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
85 is ($got, $in, "test_share_unshare_pvn");
86}
87
3a0e665e 88{
53c40a8f
NC
89 foreach ([\&XS::APItest::Hash::rot13_hash, \&rot13, "rot 13"],
90 [\&XS::APItest::Hash::bitflip_hash, \&bitflip, "bitflip"],
91 ) {
92 my ($setup, $mapping, $name) = @$_;
93 my %hash;
94 my %placebo = (a => 1, p => 2, i => 4, e => 8);
95 $setup->(\%hash);
96 $hash{a}++; @hash{qw(p i e)} = (2, 4, 8);
97
98 test_U_hash(\%hash, \%placebo, [f => 9, g => 10, h => 11], $mapping,
99 $name);
100 }
850f5f16
NC
101 foreach my $upgrade_o (0, 1) {
102 foreach my $upgrade_n (0, 1) {
103 my (%hash, %placebo);
104 XS::APItest::Hash::bitflip_hash(\%hash);
105 foreach my $new (["7", 65, 67, 80],
106 ["8", 163, 171, 215],
107 ["U", 2603, 2604, 2604],
108 ) {
109 foreach my $code (78, 240, 256, 1336) {
110 my $key = chr $code;
111 # This is the UTF-8 byte sequence for the key.
112 my $key_utf8 = $key;
113 utf8::encode($key_utf8);
114 if ($upgrade_o) {
115 $key .= chr 256;
116 chop $key;
117 }
118 $hash{$key} = $placebo{$key} = $code;
119 $hash{$key_utf8} = $placebo{$key_utf8} = "$code as UTF-8";
120 }
121 my $name = 'bitflip ' . shift @$new;
122 my @new_kv;
123 foreach my $code (@$new) {
124 my $key = chr $code;
125 if ($upgrade_n) {
126 $key .= chr 256;
127 chop $key;
128 }
129 push @new_kv, $key, $_;
130 }
131
132 $name .= ' upgraded(orig) ' if $upgrade_o;
133 $name .= ' upgraded(new) ' if $upgrade_n;
134 test_U_hash(\%hash, \%placebo, \@new_kv, \&bitflip, $name);
135 }
136 }
137 }
53c40a8f
NC
138}
139
90acdc2a
NC
140sub test_precomputed_hashes {
141 my $what = shift;
142 my $hash_it = shift;
143 my $ord = shift;
144 my $key_copy = $_[0];
145 $key_copy .= '';
146
147 my %hash;
148 is (XS::APItest::Hash::common({hv => \%hash,
149 "key$what" => $_[0],
150 val => $ord,
151 "hash_$what" => $hash_it,
152 action => XS::APItest::HV_FETCH_ISSTORE}),
153 $ord, "store $ord with $what \$hash_it = $hash_it");
154 is_deeply ([each %hash], [$_[0], $ord], "First key read is good");
155 is_deeply ([each %hash], [], "No second key good");
156
157 is ($hash{$_[0]}, $ord, "Direct hash read finds $ord");
158
159 is_deeply ([each %hash], [$key_copy, $ord],
160 "First key read is good with a copy");
161 is_deeply ([each %hash], [], "No second key good");
162
163 is ($hash{$key_copy}, $ord, "Direct hash read finds $ord");
164}
165
527df579
NC
166{
167 my $as_utf8 = "\241" . chr 256;
168 chop $as_utf8;
169 my $as_bytes = "\243";
170 foreach my $key ('N', $as_bytes, $as_utf8, "\x{2623}") {
171 my $ord = ord $key;
58ca560a
NC
172 foreach my $hash_it (0, 1) {
173 foreach my $what (qw(pv sv)) {
90acdc2a 174 test_precomputed_hashes($what, $hash_it, $ord, $key);
58ca560a 175 }
90acdc2a
NC
176 # Generate a shared hash key scalar
177 my %h = ($key => 1);
178 test_precomputed_hashes('sv', $hash_it, $ord, (keys %h)[0]);
527df579
NC
179 }
180 }
181}
182
7d6175ef
FC
183{
184 use Scalar::Util 'weaken';
185 my %h;
186 fill_hash_with_nulls(\%h);
187 my @objs;
188 for("a".."z","A".."Z") {
189 weaken($objs[@objs] = $h{$_} = []);
190 }
191 undef %h;
192 no warnings 'uninitialized';
193 local $" = "";
194 is "@objs", "",
195 'explicitly undeffing a hash with nulls frees all entries';
196
197 my $h = {};
198 fill_hash_with_nulls($h);
199 @objs = ();
200 for("a".."z","A".."Z") {
201 weaken($objs[@objs] = $$h{$_} = []);
202 }
203 undef $h;
204 is "@objs", "", 'freeing a hash with nulls frees all entries';
205}
206
207
3a0e665e 208done_testing;
53c40a8f
NC
209exit;
210
211################################ The End ################################
212
213sub test_U_hash {
214 my ($hash, $placebo, $new, $mapping, $message) = @_;
215 my @hitlist = keys %$placebo;
216 print "# $message\n";
b54b4831 217
53c40a8f
NC
218 my @keys = sort keys %$hash;
219 is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
220 "uvar magic called exactly once on store");
b54b4831 221
850f5f16 222 is (keys %$hash, keys %$placebo);
55289a74 223
53c40a8f
NC
224 my $victim = shift @hitlist;
225 is (delete $hash->{$victim}, delete $placebo->{$victim});
55289a74 226
850f5f16 227 is (keys %$hash, keys %$placebo);
53c40a8f
NC
228 @keys = sort keys %$hash;
229 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
55289a74 230
53c40a8f
NC
231 $victim = shift @hitlist;
232 is (XS::APItest::Hash::delete_ent ($hash, $victim,
55289a74
NC
233 XS::APItest::HV_DISABLE_UVAR_XKEY),
234 undef, "Deleting a known key with conversion disabled fails (ent)");
850f5f16 235 is (keys %$hash, keys %$placebo);
55289a74 236
53c40a8f
NC
237 is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
238 delete $placebo->{$victim},
239 "Deleting a known key with conversion enabled works (ent)");
850f5f16 240 is (keys %$hash, keys %$placebo);
53c40a8f
NC
241 @keys = sort keys %$hash;
242 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
55289a74 243
53c40a8f
NC
244 $victim = shift @hitlist;
245 is (XS::APItest::Hash::delete ($hash, $victim,
55289a74
NC
246 XS::APItest::HV_DISABLE_UVAR_XKEY),
247 undef, "Deleting a known key with conversion disabled fails");
850f5f16 248 is (keys %$hash, keys %$placebo);
53c40a8f
NC
249
250 is (XS::APItest::Hash::delete ($hash, $victim, 0),
251 delete $placebo->{$victim},
252 "Deleting a known key with conversion enabled works");
850f5f16 253 is (keys %$hash, keys %$placebo);
53c40a8f
NC
254 @keys = sort keys %$hash;
255 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
256
257 my ($k, $v) = splice @$new, 0, 2;
258 $hash->{$k} = $v;
259 $placebo->{$k} = $v;
850f5f16 260 is (keys %$hash, keys %$placebo);
53c40a8f
NC
261 @keys = sort keys %$hash;
262 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
263
264 ($k, $v) = splice @$new, 0, 2;
265 is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
266 $placebo->{$k} = $v;
850f5f16 267 is (keys %$hash, keys %$placebo);
53c40a8f
NC
268 @keys = sort keys %$hash;
269 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
270
271 ($k, $v) = splice @$new, 0, 2;
272 is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
53c40a8f 273 $placebo->{$k} = $v;
850f5f16 274 is (keys %$hash, keys %$placebo);
53c40a8f
NC
275 @keys = sort keys %$hash;
276 is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
277
278 @hitlist = keys %$placebo;
279 $victim = shift @hitlist;
280 is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
281 "fetch_ent");
282 is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
bdee33e4
NC
283 "fetch_ent (missing)");
284
53c40a8f
NC
285 $victim = shift @hitlist;
286 is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
287 "fetch");
288 is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
bdee33e4
NC
289 "fetch (missing)");
290
53c40a8f
NC
291 $victim = shift @hitlist;
292 ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
293 ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
bdee33e4
NC
294 "exists_ent (missing)");
295
53c40a8f 296 $victim = shift @hitlist;
6b4de907 297 die "Need a victim" unless defined $victim;
53c40a8f
NC
298 ok (XS::APItest::Hash::exists($hash, $victim), "exists");
299 ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
300 "exists (missing)");
6b4de907
NC
301
302 is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
303 $placebo->{$victim}, "common (fetch)");
304 is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
305 $placebo->{$victim}, "common (fetch pv)");
306 is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
307 action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
308 undef, "common (fetch) missing");
309 is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
310 action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
311 undef, "common (fetch pv) missing");
312 is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
313 action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
314 $placebo->{$victim}, "common (fetch) missing mapped");
315 is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
316 action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
317 $placebo->{$victim}, "common (fetch pv) missing mapped");
b54b4831
NC
318}
319
3128e575
NC
320sub main_tests {
321 my ($keys, $testkeys, $description) = @_;
322 foreach my $key (@$testkeys) {
323 my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
324 my $unikey = $key;
325 utf8::encode $unikey;
0314122a 326
3128e575
NC
327 utf8::downgrade $key, 1;
328 utf8::downgrade $lckey, 1;
329 utf8::downgrade $unikey, 1;
330 main_test_inner ($key, $lckey, $unikey, $keys, $description);
0314122a 331
3128e575
NC
332 utf8::upgrade $key;
333 utf8::upgrade $lckey;
334 utf8::upgrade $unikey;
335 main_test_inner ($key, $lckey, $unikey, $keys,
336 $description . ' [key utf8 on]');
337 }
0314122a 338
3128e575
NC
339 # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
340 # used - the utf8 flag was being lost.
341 perform_test (\&test_absent, (chr 258), $keys, '');
0314122a 342
3128e575
NC
343 perform_test (\&test_fetch_absent, (chr 258), $keys, '');
344 perform_test (\&test_delete_absent, (chr 258), $keys, '');
0314122a
NC
345}
346
3128e575
NC
347sub main_test_inner {
348 my ($key, $lckey, $unikey, $keys, $description) = @_;
349 perform_test (\&test_present, $key, $keys, $description);
350 perform_test (\&test_fetch_present, $key, $keys, $description);
351 perform_test (\&test_delete_present, $key, $keys, $description);
b60cf05a 352
3128e575
NC
353 perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
354 perform_test (\&test_store, $key, $keys, $description, []);
b60cf05a 355
3128e575
NC
356 perform_test (\&test_absent, $lckey, $keys, $description);
357 perform_test (\&test_fetch_absent, $lckey, $keys, $description);
358 perform_test (\&test_delete_absent, $lckey, $keys, $description);
b60cf05a 359
3128e575
NC
360 return if $unikey eq $key;
361
362 perform_test (\&test_absent, $unikey, $keys, $description);
363 perform_test (\&test_fetch_absent, $unikey, $keys, $description);
364 perform_test (\&test_delete_absent, $unikey, $keys, $description);
b60cf05a
NC
365}
366
3128e575
NC
367sub perform_test {
368 my ($test_sub, $key, $keys, $message, @other) = @_;
b60cf05a
NC
369 my $printable = join ',', map {ord} split //, $key;
370
3128e575
NC
371 my (%hash, %tiehash);
372 tie %tiehash, 'Tie::StdHash';
b60cf05a 373
3128e575
NC
374 @hash{@$keys} = @$keys;
375 @tiehash{@$keys} = @$keys;
b60cf05a 376
3128e575
NC
377 &$test_sub (\%hash, $key, $printable, $message, @other);
378 &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
b60cf05a
NC
379}
380
3128e575
NC
381sub test_present {
382 my ($hash, $key, $printable, $message) = @_;
383
384 ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
385 ok (XS::APItest::Hash::exists ($hash, $key),
386 "hv_exists present$message $printable");
b60cf05a
NC
387}
388
3128e575
NC
389sub test_absent {
390 my ($hash, $key, $printable, $message) = @_;
858117f8 391
3128e575
NC
392 ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
393 ok (!XS::APItest::Hash::exists ($hash, $key),
394 "hv_exists absent$message $printable");
b60cf05a
NC
395}
396
3128e575
NC
397sub test_delete_present {
398 my ($hash, $key, $printable, $message) = @_;
b60cf05a 399
3128e575
NC
400 my $copy = {};
401 my $class = tied %$hash;
402 if (defined $class) {
403 tie %$copy, ref $class;
404 }
405 $copy = {%$hash};
8829b5e2
NC
406 ok (brute_force_exists ($copy, $key),
407 "hv_delete_ent present$message $printable");
3128e575 408 is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
8829b5e2
NC
409 ok (!brute_force_exists ($copy, $key),
410 "hv_delete_ent present$message $printable");
3128e575 411 $copy = {%$hash};
8829b5e2
NC
412 ok (brute_force_exists ($copy, $key),
413 "hv_delete present$message $printable");
3128e575
NC
414 is (XS::APItest::Hash::delete ($copy, $key), $key,
415 "hv_delete present$message $printable");
8829b5e2
NC
416 ok (!brute_force_exists ($copy, $key),
417 "hv_delete present$message $printable");
b60cf05a
NC
418}
419
3128e575
NC
420sub test_delete_absent {
421 my ($hash, $key, $printable, $message) = @_;
b60cf05a 422
3128e575
NC
423 my $copy = {};
424 my $class = tied %$hash;
425 if (defined $class) {
426 tie %$copy, ref $class;
427 }
428 $copy = {%$hash};
429 is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
430 $copy = {%$hash};
431 is (XS::APItest::Hash::delete ($copy, $key), undef,
432 "hv_delete absent$message $printable");
b60cf05a
NC
433}
434
3128e575
NC
435sub test_store {
436 my ($hash, $key, $printable, $message, $defaults) = @_;
437 my $HV_STORE_IS_CRAZY = 1;
b60cf05a 438
3128e575
NC
439 # We are cheating - hv_store returns NULL for a store into an empty
440 # tied hash. This isn't helpful here.
0314122a 441
3128e575 442 my $class = tied %$hash;
0314122a 443
9568a123
NC
444 # It's important to do this with nice new hashes created each time round
445 # the loop, rather than hashes in the pad, which get recycled, and may have
446 # xhv_array non-NULL
447 my $h1 = {@$defaults};
448 my $h2 = {@$defaults};
3128e575 449 if (defined $class) {
9568a123
NC
450 tie %$h1, ref $class;
451 tie %$h2, ref $class;
452 if ($] > 5.009) {
453 # bug 36327 is fixed
454 $HV_STORE_IS_CRAZY = undef;
455 } else {
456 # HV store_ent returns 1 if there was already underlying hash storage
457 $HV_STORE_IS_CRAZY = undef unless @$defaults;
458 }
3128e575 459 }
9568a123
NC
460 is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
461 "hv_store_ent$message $printable");
462 ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
463 is (XS::APItest::Hash::store($h2, $key, 1), $HV_STORE_IS_CRAZY,
3128e575 464 "hv_store$message $printable");
9568a123 465 ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
3128e575 466}
0314122a 467
3128e575
NC
468sub test_fetch_present {
469 my ($hash, $key, $printable, $message) = @_;
b60cf05a 470
3128e575
NC
471 is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
472 is (XS::APItest::Hash::fetch ($hash, $key), $key,
473 "hv_fetch present$message $printable");
0314122a
NC
474}
475
3128e575
NC
476sub test_fetch_absent {
477 my ($hash, $key, $printable, $message) = @_;
b60cf05a 478
3128e575
NC
479 is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
480 is (XS::APItest::Hash::fetch ($hash, $key), undef,
481 "hv_fetch absent$message $printable");
482}
b60cf05a 483
3128e575
NC
484sub brute_force_exists {
485 my ($hash, $key) = @_;
486 foreach (keys %$hash) {
487 return 1 if $key eq $_;
488 }
489 return 0;
b60cf05a 490}
b54b4831
NC
491
492sub rot13 {
493 my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
494 wantarray ? @results : $results[0];
495}
53c40a8f
NC
496
497sub bitflip {
498 my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
499 wantarray ? @results : $results[0];
500}