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