This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8e6beeea8e987d415c0ff6575dc4991d3b73244c
[perl5.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 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 (XS::APItest::Hash::store(\%h, chr 258,  1), 1);
53     
54   ok (!exists $h{$utf8_for_258},
55       "hv_store doesn't insert a key with the raw utf8 on a tied hash");
56 }
57
58 {
59     my $strtab = strtab();
60     is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
61     my $wibble = "\0";
62     eval {
63         $strtab->{$wibble}++;
64     };
65     my $prefix = "Cannot modify shared string table in hv_";
66     my $what = $prefix . 'fetch';
67     like ($@, qr/^$what/,$what);
68     eval {
69         XS::APItest::Hash::store($strtab, 'Boom!',  1)
70     };
71     $what = $prefix . 'store';
72     like ($@, qr/^$what/, $what);
73     if (0) {
74         A::B->method();
75     }
76     # DESTROY should be in there.
77     eval {
78         delete $strtab->{DESTROY};
79     };
80     $what = $prefix . 'delete';
81     like ($@, qr/^$what/, $what);
82     # I can't work out how to get to the code that flips the wasutf8 flag on
83     # the hash key without some ikcy XS
84 }
85 exit;
86
87 ################################   The End   ################################
88
89 sub main_tests {
90   my ($keys, $testkeys, $description) = @_;
91   foreach my $key (@$testkeys) {
92     my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
93     my $unikey = $key;
94     utf8::encode $unikey;
95
96     utf8::downgrade $key, 1;
97     utf8::downgrade $lckey, 1;
98     utf8::downgrade $unikey, 1;
99     main_test_inner ($key, $lckey, $unikey, $keys, $description);
100
101     utf8::upgrade $key;
102     utf8::upgrade $lckey;
103     utf8::upgrade $unikey;
104     main_test_inner ($key, $lckey, $unikey, $keys,
105                      $description . ' [key utf8 on]');
106   }
107
108   # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
109   # used - the utf8 flag was being lost.
110   perform_test (\&test_absent, (chr 258), $keys, '');
111
112   perform_test (\&test_fetch_absent, (chr 258), $keys, '');
113   perform_test (\&test_delete_absent, (chr 258), $keys, '');
114 }
115
116 sub main_test_inner {
117   my ($key, $lckey, $unikey, $keys, $description) = @_;
118   perform_test (\&test_present, $key, $keys, $description);
119   perform_test (\&test_fetch_present, $key, $keys, $description);
120   perform_test (\&test_delete_present, $key, $keys, $description);
121
122   perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
123   perform_test (\&test_store, $key, $keys, $description, []);
124
125   perform_test (\&test_absent, $lckey, $keys, $description);
126   perform_test (\&test_fetch_absent, $lckey, $keys, $description);
127   perform_test (\&test_delete_absent, $lckey, $keys, $description);
128
129   return if $unikey eq $key;
130
131   perform_test (\&test_absent, $unikey, $keys, $description);
132   perform_test (\&test_fetch_absent, $unikey, $keys, $description);
133   perform_test (\&test_delete_absent, $unikey, $keys, $description);
134 }
135
136 sub perform_test {
137   my ($test_sub, $key, $keys, $message, @other) = @_;
138   my $printable = join ',', map {ord} split //, $key;
139
140   my (%hash, %tiehash);
141   tie %tiehash, 'Tie::StdHash';
142
143   @hash{@$keys} = @$keys;
144   @tiehash{@$keys} = @$keys;
145
146   &$test_sub (\%hash, $key, $printable, $message, @other);
147   &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
148 }
149
150 sub test_present {
151   my ($hash, $key, $printable, $message) = @_;
152
153   ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
154   ok (XS::APItest::Hash::exists ($hash, $key),
155       "hv_exists present$message $printable");
156 }
157
158 sub test_absent {
159   my ($hash, $key, $printable, $message) = @_;
160
161   ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
162   ok (!XS::APItest::Hash::exists ($hash, $key),
163       "hv_exists absent$message $printable");
164 }
165
166 sub test_delete_present {
167   my ($hash, $key, $printable, $message) = @_;
168
169   my $copy = {};
170   my $class = tied %$hash;
171   if (defined $class) {
172     tie %$copy, ref $class;
173   }
174   $copy = {%$hash};
175   ok (brute_force_exists ($copy, $key),
176       "hv_delete_ent present$message $printable");
177   is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
178   ok (!brute_force_exists ($copy, $key),
179       "hv_delete_ent present$message $printable");
180   $copy = {%$hash};
181   ok (brute_force_exists ($copy, $key),
182       "hv_delete present$message $printable");
183   is (XS::APItest::Hash::delete ($copy, $key), $key,
184       "hv_delete present$message $printable");
185   ok (!brute_force_exists ($copy, $key),
186       "hv_delete present$message $printable");
187 }
188
189 sub test_delete_absent {
190   my ($hash, $key, $printable, $message) = @_;
191
192   my $copy = {};
193   my $class = tied %$hash;
194   if (defined $class) {
195     tie %$copy, ref $class;
196   }
197   $copy = {%$hash};
198   is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
199   $copy = {%$hash};
200   is (XS::APItest::Hash::delete ($copy, $key), undef,
201       "hv_delete absent$message $printable");
202 }
203
204 sub test_store {
205   my ($hash, $key, $printable, $message, $defaults) = @_;
206   my $HV_STORE_IS_CRAZY = 1;
207
208   # We are cheating - hv_store returns NULL for a store into an empty
209   # tied hash. This isn't helpful here.
210
211   my $class = tied %$hash;
212
213   my %h1 = @$defaults;
214   my %h2 = @$defaults;
215   if (defined $class) {
216     tie %h1, ref $class;
217     tie %h2, ref $class;
218     $HV_STORE_IS_CRAZY = undef unless @$defaults;
219   }
220   is (XS::APItest::Hash::store_ent(\%h1, $key, 1), 1,
221       "hv_store_ent$message $printable"); 
222   ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable");
223   is (XS::APItest::Hash::store(\%h2, $key,  1), $HV_STORE_IS_CRAZY,
224       "hv_store$message $printable");
225   ok (brute_force_exists (\%h2, $key), "hv_store$message $printable");
226 }
227
228 sub test_fetch_present {
229   my ($hash, $key, $printable, $message) = @_;
230
231   is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
232   is (XS::APItest::Hash::fetch ($hash, $key), $key,
233       "hv_fetch present$message $printable");
234 }
235
236 sub test_fetch_absent {
237   my ($hash, $key, $printable, $message) = @_;
238
239   is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
240   is (XS::APItest::Hash::fetch ($hash, $key), undef,
241       "hv_fetch absent$message $printable");
242 }
243
244 sub brute_force_exists {
245   my ($hash, $key) = @_;
246   foreach (keys %$hash) {
247     return 1 if $key eq $_;
248   }
249   return 0;
250 }