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