This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/lib/feature/implicit: Generalize for non-ASCII platforms
[perl5.git] / ext / XS-APItest / t / hash.t
1 #!perl -w
2
3 use strict;
4 use utf8;
5 use Tie::Hash;
6 use Test::More;
7
8 BEGIN {use_ok('XS::APItest')};
9
10 sub preform_test;
11 sub test_present;
12 sub test_absent;
13 sub test_delete_present;
14 sub test_delete_absent;
15 sub brute_force_exists;
16 sub test_store;
17 sub test_fetch_present;
18 sub test_fetch_absent;
19
20 my $utf8_for_258 = chr 258;
21 utf8::encode $utf8_for_258;
22
23 my @testkeys = ('N', chr 198, chr 256);
24 my @keys = (@testkeys, $utf8_for_258);
25
26 foreach (@keys) {
27   utf8::downgrade $_, 1;
28 }
29 main_tests (\@keys, \@testkeys, '');
30
31 foreach (@keys) {
32   utf8::upgrade $_;
33 }
34 main_tests (\@keys, \@testkeys, ' [utf8 hash]');
35
36 {
37   my %h = (a=>'cheat');
38   tie %h, 'Tie::StdHash';
39   # is bug 36327 fixed?
40   my $result = ($] > 5.009) ? undef : 1;
41
42   is (XS::APItest::Hash::store(\%h, chr 258,  1), $result);
43
44   ok (!exists $h{$utf8_for_258},
45       "hv_store doesn't insert a key with the raw utf8 on a tied hash");
46 }
47
48 {
49     my $strtab = strtab();
50     is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
51     my $wibble = "\0";
52     eval {
53         $strtab->{$wibble}++;
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 }
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 }
82
83 foreach 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
88 {
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     }
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     }
138 }
139
140 sub 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
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;
172         foreach my $hash_it (0, 1) {
173             foreach my $what (qw(pv sv)) {
174                 test_precomputed_hashes($what, $hash_it, $ord, $key);
175             }
176             # Generate a shared hash key scalar
177             my %h = ($key => 1);
178             test_precomputed_hashes('sv', $hash_it, $ord, (keys %h)[0]);
179         }
180     }
181 }
182
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 # Tests for HvENAME and UTF8
208 {
209     no strict;
210     no warnings 'void';
211     my $hvref;
212
213     *{"\xff::bar"}; # autovivify %ÿ:: without UTF8
214     *{"\xff::bαr::"} = $hvref = \%foo::;
215     undef *foo::;
216     is HvENAME($hvref), "\xff::bαr",
217         'stash alias (utf8 inside bytes) does not create malformed UTF8';
218
219     *{"é::foo"}; # autovivify %é:: with UTF8
220     *{"\xe9::\xe9::"} = $hvref = \%bar::;
221     undef *bar::;
222     is HvENAME($hvref), "\xe9::\xe9",
223         'stash alias (bytes inside utf8) does not create malformed UTF8';
224
225     *{"\xfe::bar"}; *{"\xfd::bar"};
226     *{"\xfe::bαr::"} = \%goo::;
227     *{"\xfd::bαr::"} = $hvref = \%goo::;
228     undef *goo::;
229     like HvENAME($hvref), qr/^[\xfe\xfd]::bαr\z/,
230         'multiple stash aliases (utf8 inside bytes) do not cause bad UTF8';
231
232     *{"è::foo"}; *{"ë::foo"};
233     *{"\xe8::\xe9::"} = $hvref = \%bear::;
234     *{"\xeb::\xe9::"} = \%bear::;
235     undef *bear::;
236     like HvENAME($hvref), qr"^[\xe8\xeb]::\xe9\z",
237         'multiple stash aliases (bytes inside utf8) do not cause bad UTF8';
238 }
239
240 { # newHVhv
241     use Tie::Hash;
242     tie my %h, 'Tie::StdHash';
243     %h = 1..10;
244     is join(' ', sort %{newHVhv \%h}), '1 10 2 3 4 5 6 7 8 9',
245       'newHVhv on tied hash';
246 }
247
248 # helem and hslice on entry with null value
249 # This is actually a test for a Perl operator, not an XS API test.  But it
250 # requires a hash that can only be produced by XS (although recently it
251 # could be encountered when tying hint hashes).
252 {
253     my %h;
254     fill_hash_with_nulls(\%h);
255     eval{ $h{84} = 1 };
256     pass 'no crash when writing to hash elem with null value';
257     eval{ no # silly
258           warnings; # thank you!
259           @h{85} = 1 };
260     pass 'no crash when writing to hash elem with null value via slice';
261     eval { delete local $h{86} };
262     pass 'no crash during local deletion of hash elem with null value';
263     eval { delete local @h{87,88} };
264     pass 'no crash during local deletion of hash slice with null values';
265 }
266
267 # [perl #111000] Bug number eleventy-one thousand:
268 #                hv_store should work on hint hashes
269 eval q{
270     BEGIN {
271         XS::APItest::Hash::store \%^H, "XS::APItest/hash.t", undef;
272         delete $^H{"XS::APItest/hash.t"};
273     }
274 };
275 pass("hv_store works on the hint hash");
276
277 {
278     # [perl #79074] HeSVKEY_force loses UTF8ness
279     my %hash = ( "\xff" => 1, "\x{100}" => 1 );
280     my @keys = sort ( XS::APItest::Hash::test_force_keys(\%hash) );
281     is_deeply(\@keys, [ sort keys %hash ], "check HeSVKEY_force()");
282 }
283
284 done_testing;
285 exit;
286
287 ################################   The End   ################################
288
289 sub test_U_hash {
290     my ($hash, $placebo, $new, $mapping, $message) = @_;
291     my @hitlist = keys %$placebo;
292     print "# $message\n";
293
294     my @keys = sort keys %$hash;
295     is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
296         "uvar magic called exactly once on store");
297
298     is (keys %$hash, keys %$placebo);
299
300     my $victim = shift @hitlist;
301     is (delete $hash->{$victim}, delete $placebo->{$victim});
302
303     is (keys %$hash, keys %$placebo);
304     @keys = sort keys %$hash;
305     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
306
307     $victim = shift @hitlist;
308     is (XS::APItest::Hash::delete_ent ($hash, $victim,
309                                        XS::APItest::HV_DISABLE_UVAR_XKEY),
310         undef, "Deleting a known key with conversion disabled fails (ent)");
311     is (keys %$hash, keys %$placebo);
312
313     is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
314         delete $placebo->{$victim},
315         "Deleting a known key with conversion enabled works (ent)");
316     is (keys %$hash, keys %$placebo);
317     @keys = sort keys %$hash;
318     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
319
320     $victim = shift @hitlist;
321     is (XS::APItest::Hash::delete ($hash, $victim,
322                                    XS::APItest::HV_DISABLE_UVAR_XKEY),
323         undef, "Deleting a known key with conversion disabled fails");
324     is (keys %$hash, keys %$placebo);
325
326     is (XS::APItest::Hash::delete ($hash, $victim, 0),
327         delete $placebo->{$victim},
328         "Deleting a known key with conversion enabled works");
329     is (keys %$hash, keys %$placebo);
330     @keys = sort keys %$hash;
331     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
332
333     my ($k, $v) = splice @$new, 0, 2;
334     $hash->{$k} = $v;
335     $placebo->{$k} = $v;
336     is (keys %$hash, keys %$placebo);
337     @keys = sort keys %$hash;
338     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
339
340     ($k, $v) = splice @$new, 0, 2;
341     is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
342     $placebo->{$k} = $v;
343     is (keys %$hash, keys %$placebo);
344     @keys = sort keys %$hash;
345     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
346
347     ($k, $v) = splice @$new, 0, 2;
348     is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
349     $placebo->{$k} = $v;
350     is (keys %$hash, keys %$placebo);
351     @keys = sort keys %$hash;
352     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
353
354     @hitlist = keys %$placebo;
355     $victim = shift @hitlist;
356     is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
357         "fetch_ent");
358     is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
359         "fetch_ent (missing)");
360
361     $victim = shift @hitlist;
362     is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
363         "fetch");
364     is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
365         "fetch (missing)");
366
367     $victim = shift @hitlist;
368     ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
369     ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
370         "exists_ent (missing)");
371
372     $victim = shift @hitlist;
373     die "Need a victim" unless defined $victim;
374     ok (XS::APItest::Hash::exists($hash, $victim), "exists");
375     ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
376         "exists (missing)");
377
378     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
379         $placebo->{$victim}, "common (fetch)");
380     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
381         $placebo->{$victim}, "common (fetch pv)");
382     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
383                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
384         undef, "common (fetch) missing");
385     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
386                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
387         undef, "common (fetch pv) missing");
388     is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
389                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
390         $placebo->{$victim}, "common (fetch) missing mapped");
391     is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
392                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
393         $placebo->{$victim}, "common (fetch pv) missing mapped");
394 }
395
396 sub main_tests {
397   my ($keys, $testkeys, $description) = @_;
398   foreach my $key (@$testkeys) {
399     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
400     my $unikey = $key;
401     utf8::encode $unikey;
402
403     utf8::downgrade $key, 1;
404     utf8::downgrade $lckey, 1;
405     utf8::downgrade $unikey, 1;
406     main_test_inner ($key, $lckey, $unikey, $keys, $description);
407
408     utf8::upgrade $key;
409     utf8::upgrade $lckey;
410     utf8::upgrade $unikey;
411     main_test_inner ($key, $lckey, $unikey, $keys,
412                      $description . ' [key utf8 on]');
413   }
414
415   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
416   # used - the utf8 flag was being lost.
417   perform_test (\&test_absent, (chr 258), $keys, '');
418
419   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
420   perform_test (\&test_delete_absent, (chr 258), $keys, '');
421 }
422
423 sub main_test_inner {
424   my ($key, $lckey, $unikey, $keys, $description) = @_;
425   perform_test (\&test_present, $key, $keys, $description);
426   perform_test (\&test_fetch_present, $key, $keys, $description);
427   perform_test (\&test_delete_present, $key, $keys, $description);
428
429   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
430   perform_test (\&test_store, $key, $keys, $description, []);
431
432   perform_test (\&test_absent, $lckey, $keys, $description);
433   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
434   perform_test (\&test_delete_absent, $lckey, $keys, $description);
435
436   return if $unikey eq $key;
437
438   perform_test (\&test_absent, $unikey, $keys, $description);
439   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
440   perform_test (\&test_delete_absent, $unikey, $keys, $description);
441 }
442
443 sub perform_test {
444   my ($test_sub, $key, $keys, $message, @other) = @_;
445   my $printable = join ',', map {ord} split //, $key;
446
447   my (%hash, %tiehash);
448   tie %tiehash, 'Tie::StdHash';
449
450   @hash{@$keys} = @$keys;
451   @tiehash{@$keys} = @$keys;
452
453   &$test_sub (\%hash, $key, $printable, $message, @other);
454   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
455 }
456
457 sub test_present {
458   my ($hash, $key, $printable, $message) = @_;
459
460   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
461   ok (XS::APItest::Hash::exists ($hash, $key),
462       "hv_exists present$message $printable");
463 }
464
465 sub test_absent {
466   my ($hash, $key, $printable, $message) = @_;
467
468   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
469   ok (!XS::APItest::Hash::exists ($hash, $key),
470       "hv_exists absent$message $printable");
471 }
472
473 sub test_delete_present {
474   my ($hash, $key, $printable, $message) = @_;
475
476   my $copy = {};
477   my $class = tied %$hash;
478   if (defined $class) {
479     tie %$copy, ref $class;
480   }
481   $copy = {%$hash};
482   ok (brute_force_exists ($copy, $key),
483       "hv_delete_ent present$message $printable");
484   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
485   ok (!brute_force_exists ($copy, $key),
486       "hv_delete_ent present$message $printable");
487   $copy = {%$hash};
488   ok (brute_force_exists ($copy, $key),
489       "hv_delete present$message $printable");
490   is (XS::APItest::Hash::delete ($copy, $key), $key,
491       "hv_delete present$message $printable");
492   ok (!brute_force_exists ($copy, $key),
493       "hv_delete present$message $printable");
494 }
495
496 sub test_delete_absent {
497   my ($hash, $key, $printable, $message) = @_;
498
499   my $copy = {};
500   my $class = tied %$hash;
501   if (defined $class) {
502     tie %$copy, ref $class;
503   }
504   $copy = {%$hash};
505   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
506   $copy = {%$hash};
507   is (XS::APItest::Hash::delete ($copy, $key), undef,
508       "hv_delete absent$message $printable");
509 }
510
511 sub test_store {
512   my ($hash, $key, $printable, $message, $defaults) = @_;
513   my $HV_STORE_IS_CRAZY = 1;
514
515   # We are cheating - hv_store returns NULL for a store into an empty
516   # tied hash. This isn't helpful here.
517
518   my $class = tied %$hash;
519
520   # It's important to do this with nice new hashes created each time round
521   # the loop, rather than hashes in the pad, which get recycled, and may have
522   # xhv_array non-NULL
523   my $h1 = {@$defaults};
524   my $h2 = {@$defaults};
525   if (defined $class) {
526     tie %$h1, ref $class;
527     tie %$h2, ref $class;
528     if ($] > 5.009) {
529       # bug 36327 is fixed
530       $HV_STORE_IS_CRAZY = undef;
531     } else {
532       # HV store_ent returns 1 if there was already underlying hash storage
533       $HV_STORE_IS_CRAZY = undef unless @$defaults;
534     }
535   }
536   is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
537       "hv_store_ent$message $printable");
538   ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
539   is (XS::APItest::Hash::store($h2, $key,  1), $HV_STORE_IS_CRAZY,
540       "hv_store$message $printable");
541   ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
542 }
543
544 sub test_fetch_present {
545   my ($hash, $key, $printable, $message) = @_;
546
547   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
548   is (XS::APItest::Hash::fetch ($hash, $key), $key,
549       "hv_fetch present$message $printable");
550 }
551
552 sub test_fetch_absent {
553   my ($hash, $key, $printable, $message) = @_;
554
555   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
556   is (XS::APItest::Hash::fetch ($hash, $key), undef,
557       "hv_fetch absent$message $printable");
558 }
559
560 sub brute_force_exists {
561   my ($hash, $key) = @_;
562   foreach (keys %$hash) {
563     return 1 if $key eq $_;
564   }
565   return 0;
566 }
567
568 sub rot13 {
569     my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
570     wantarray ? @results : $results[0];
571 }
572
573 sub bitflip {
574     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
575     wantarray ? @results : $results[0];
576 }