This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
84b6274bdd3632c9e6f6d3da1de8416f5792a8c9
[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 }
262
263 # [perl #111000] Bug number eleventy-one thousand:
264 #                hv_store should work on hint hashes
265 eval q{
266     BEGIN {
267         XS::APItest::Hash::store \%^H, "XS::APItest/hash.t", undef;
268         delete $^H{"XS::APItest/hash.t"};
269     }
270 };
271 pass("hv_store works on the hint hash");
272
273 done_testing;
274 exit;
275
276 ################################   The End   ################################
277
278 sub test_U_hash {
279     my ($hash, $placebo, $new, $mapping, $message) = @_;
280     my @hitlist = keys %$placebo;
281     print "# $message\n";
282
283     my @keys = sort keys %$hash;
284     is ("@keys", join(' ', sort($mapping->(keys %$placebo))),
285         "uvar magic called exactly once on store");
286
287     is (keys %$hash, keys %$placebo);
288
289     my $victim = shift @hitlist;
290     is (delete $hash->{$victim}, delete $placebo->{$victim});
291
292     is (keys %$hash, keys %$placebo);
293     @keys = sort keys %$hash;
294     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
295
296     $victim = shift @hitlist;
297     is (XS::APItest::Hash::delete_ent ($hash, $victim,
298                                        XS::APItest::HV_DISABLE_UVAR_XKEY),
299         undef, "Deleting a known key with conversion disabled fails (ent)");
300     is (keys %$hash, keys %$placebo);
301
302     is (XS::APItest::Hash::delete_ent ($hash, $victim, 0),
303         delete $placebo->{$victim},
304         "Deleting a known key with conversion enabled works (ent)");
305     is (keys %$hash, keys %$placebo);
306     @keys = sort keys %$hash;
307     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
308
309     $victim = shift @hitlist;
310     is (XS::APItest::Hash::delete ($hash, $victim,
311                                    XS::APItest::HV_DISABLE_UVAR_XKEY),
312         undef, "Deleting a known key with conversion disabled fails");
313     is (keys %$hash, keys %$placebo);
314
315     is (XS::APItest::Hash::delete ($hash, $victim, 0),
316         delete $placebo->{$victim},
317         "Deleting a known key with conversion enabled works");
318     is (keys %$hash, keys %$placebo);
319     @keys = sort keys %$hash;
320     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
321
322     my ($k, $v) = splice @$new, 0, 2;
323     $hash->{$k} = $v;
324     $placebo->{$k} = $v;
325     is (keys %$hash, keys %$placebo);
326     @keys = sort keys %$hash;
327     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
328
329     ($k, $v) = splice @$new, 0, 2;
330     is (XS::APItest::Hash::store_ent($hash, $k, $v), $v, "store_ent");
331     $placebo->{$k} = $v;
332     is (keys %$hash, keys %$placebo);
333     @keys = sort keys %$hash;
334     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
335
336     ($k, $v) = splice @$new, 0, 2;
337     is (XS::APItest::Hash::store($hash, $k, $v), $v, "store");
338     $placebo->{$k} = $v;
339     is (keys %$hash, keys %$placebo);
340     @keys = sort keys %$hash;
341     is ("@keys", join(' ', sort($mapping->(keys %$placebo))));
342
343     @hitlist = keys %$placebo;
344     $victim = shift @hitlist;
345     is (XS::APItest::Hash::fetch_ent($hash, $victim), $placebo->{$victim},
346         "fetch_ent");
347     is (XS::APItest::Hash::fetch_ent($hash, $mapping->($victim)), undef,
348         "fetch_ent (missing)");
349
350     $victim = shift @hitlist;
351     is (XS::APItest::Hash::fetch($hash, $victim), $placebo->{$victim},
352         "fetch");
353     is (XS::APItest::Hash::fetch($hash, $mapping->($victim)), undef,
354         "fetch (missing)");
355
356     $victim = shift @hitlist;
357     ok (XS::APItest::Hash::exists_ent($hash, $victim), "exists_ent");
358     ok (!XS::APItest::Hash::exists_ent($hash, $mapping->($victim)),
359         "exists_ent (missing)");
360
361     $victim = shift @hitlist;
362     die "Need a victim" unless defined $victim;
363     ok (XS::APItest::Hash::exists($hash, $victim), "exists");
364     ok (!XS::APItest::Hash::exists($hash, $mapping->($victim)),
365         "exists (missing)");
366
367     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim}),
368         $placebo->{$victim}, "common (fetch)");
369     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim}),
370         $placebo->{$victim}, "common (fetch pv)");
371     is (XS::APItest::Hash::common({hv => $hash, keysv => $victim,
372                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
373         undef, "common (fetch) missing");
374     is (XS::APItest::Hash::common({hv => $hash, keypv => $victim,
375                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
376         undef, "common (fetch pv) missing");
377     is (XS::APItest::Hash::common({hv => $hash, keysv => $mapping->($victim),
378                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
379         $placebo->{$victim}, "common (fetch) missing mapped");
380     is (XS::APItest::Hash::common({hv => $hash, keypv => $mapping->($victim),
381                                    action => XS::APItest::HV_DISABLE_UVAR_XKEY}),
382         $placebo->{$victim}, "common (fetch pv) missing mapped");
383 }
384
385 sub main_tests {
386   my ($keys, $testkeys, $description) = @_;
387   foreach my $key (@$testkeys) {
388     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
389     my $unikey = $key;
390     utf8::encode $unikey;
391
392     utf8::downgrade $key, 1;
393     utf8::downgrade $lckey, 1;
394     utf8::downgrade $unikey, 1;
395     main_test_inner ($key, $lckey, $unikey, $keys, $description);
396
397     utf8::upgrade $key;
398     utf8::upgrade $lckey;
399     utf8::upgrade $unikey;
400     main_test_inner ($key, $lckey, $unikey, $keys,
401                      $description . ' [key utf8 on]');
402   }
403
404   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
405   # used - the utf8 flag was being lost.
406   perform_test (\&test_absent, (chr 258), $keys, '');
407
408   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
409   perform_test (\&test_delete_absent, (chr 258), $keys, '');
410 }
411
412 sub main_test_inner {
413   my ($key, $lckey, $unikey, $keys, $description) = @_;
414   perform_test (\&test_present, $key, $keys, $description);
415   perform_test (\&test_fetch_present, $key, $keys, $description);
416   perform_test (\&test_delete_present, $key, $keys, $description);
417
418   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
419   perform_test (\&test_store, $key, $keys, $description, []);
420
421   perform_test (\&test_absent, $lckey, $keys, $description);
422   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
423   perform_test (\&test_delete_absent, $lckey, $keys, $description);
424
425   return if $unikey eq $key;
426
427   perform_test (\&test_absent, $unikey, $keys, $description);
428   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
429   perform_test (\&test_delete_absent, $unikey, $keys, $description);
430 }
431
432 sub perform_test {
433   my ($test_sub, $key, $keys, $message, @other) = @_;
434   my $printable = join ',', map {ord} split //, $key;
435
436   my (%hash, %tiehash);
437   tie %tiehash, 'Tie::StdHash';
438
439   @hash{@$keys} = @$keys;
440   @tiehash{@$keys} = @$keys;
441
442   &$test_sub (\%hash, $key, $printable, $message, @other);
443   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
444 }
445
446 sub test_present {
447   my ($hash, $key, $printable, $message) = @_;
448
449   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
450   ok (XS::APItest::Hash::exists ($hash, $key),
451       "hv_exists present$message $printable");
452 }
453
454 sub test_absent {
455   my ($hash, $key, $printable, $message) = @_;
456
457   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
458   ok (!XS::APItest::Hash::exists ($hash, $key),
459       "hv_exists absent$message $printable");
460 }
461
462 sub test_delete_present {
463   my ($hash, $key, $printable, $message) = @_;
464
465   my $copy = {};
466   my $class = tied %$hash;
467   if (defined $class) {
468     tie %$copy, ref $class;
469   }
470   $copy = {%$hash};
471   ok (brute_force_exists ($copy, $key),
472       "hv_delete_ent present$message $printable");
473   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
474   ok (!brute_force_exists ($copy, $key),
475       "hv_delete_ent present$message $printable");
476   $copy = {%$hash};
477   ok (brute_force_exists ($copy, $key),
478       "hv_delete present$message $printable");
479   is (XS::APItest::Hash::delete ($copy, $key), $key,
480       "hv_delete present$message $printable");
481   ok (!brute_force_exists ($copy, $key),
482       "hv_delete present$message $printable");
483 }
484
485 sub test_delete_absent {
486   my ($hash, $key, $printable, $message) = @_;
487
488   my $copy = {};
489   my $class = tied %$hash;
490   if (defined $class) {
491     tie %$copy, ref $class;
492   }
493   $copy = {%$hash};
494   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
495   $copy = {%$hash};
496   is (XS::APItest::Hash::delete ($copy, $key), undef,
497       "hv_delete absent$message $printable");
498 }
499
500 sub test_store {
501   my ($hash, $key, $printable, $message, $defaults) = @_;
502   my $HV_STORE_IS_CRAZY = 1;
503
504   # We are cheating - hv_store returns NULL for a store into an empty
505   # tied hash. This isn't helpful here.
506
507   my $class = tied %$hash;
508
509   # It's important to do this with nice new hashes created each time round
510   # the loop, rather than hashes in the pad, which get recycled, and may have
511   # xhv_array non-NULL
512   my $h1 = {@$defaults};
513   my $h2 = {@$defaults};
514   if (defined $class) {
515     tie %$h1, ref $class;
516     tie %$h2, ref $class;
517     if ($] > 5.009) {
518       # bug 36327 is fixed
519       $HV_STORE_IS_CRAZY = undef;
520     } else {
521       # HV store_ent returns 1 if there was already underlying hash storage
522       $HV_STORE_IS_CRAZY = undef unless @$defaults;
523     }
524   }
525   is (XS::APItest::Hash::store_ent($h1, $key, 1), $HV_STORE_IS_CRAZY,
526       "hv_store_ent$message $printable");
527   ok (brute_force_exists ($h1, $key), "hv_store_ent$message $printable");
528   is (XS::APItest::Hash::store($h2, $key,  1), $HV_STORE_IS_CRAZY,
529       "hv_store$message $printable");
530   ok (brute_force_exists ($h2, $key), "hv_store$message $printable");
531 }
532
533 sub test_fetch_present {
534   my ($hash, $key, $printable, $message) = @_;
535
536   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
537   is (XS::APItest::Hash::fetch ($hash, $key), $key,
538       "hv_fetch present$message $printable");
539 }
540
541 sub test_fetch_absent {
542   my ($hash, $key, $printable, $message) = @_;
543
544   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
545   is (XS::APItest::Hash::fetch ($hash, $key), undef,
546       "hv_fetch absent$message $printable");
547 }
548
549 sub brute_force_exists {
550   my ($hash, $key) = @_;
551   foreach (keys %$hash) {
552     return 1 if $key eq $_;
553   }
554   return 0;
555 }
556
557 sub rot13 {
558     my @results = map {my $a = $_; $a =~ tr/A-Za-z/N-ZA-Mn-za-m/; $a} @_;
559     wantarray ? @results : $results[0];
560 }
561
562 sub bitflip {
563     my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_;
564     wantarray ? @results : $results[0];
565 }