Commit | Line | Data |
0314122a |
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 | |
3128e575 |
16 | use strict; |
17 | use utf8; |
0314122a |
18 | use Tie::Hash; |
3128e575 |
19 | use Test::More 'no_plan'; |
20 | |
21 | use_ok('XS::APItest'); |
0314122a |
22 | |
3128e575 |
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; |
0314122a |
32 | |
b60cf05a |
33 | my $utf8_for_258 = chr 258; |
34 | utf8::encode $utf8_for_258; |
0314122a |
35 | |
3128e575 |
36 | my @testkeys = ('N', chr 198, chr 256); |
b60cf05a |
37 | my @keys = (@testkeys, $utf8_for_258); |
0314122a |
38 | |
3128e575 |
39 | foreach (@keys) { |
40 | utf8::downgrade $_, 1; |
41 | } |
42 | main_tests (\@keys, \@testkeys, ''); |
0314122a |
43 | |
3128e575 |
44 | foreach (@keys) { |
45 | utf8::upgrade $_; |
46 | } |
47 | main_tests (\@keys, \@testkeys, ' [utf8 hash]'); |
0314122a |
48 | |
3128e575 |
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 | } |
0314122a |
57 | |
3128e575 |
58 | exit; |
0314122a |
59 | |
3128e575 |
60 | ################################ The End ################################ |
0314122a |
61 | |
3128e575 |
62 | sub main_tests { |
63 | my ($keys, $testkeys, $description) = @_; |
64 | foreach my $key (@$testkeys) { |
65 | my $lckey = ($key eq chr 198) ? chr 230 : lc $key; |
66 | my $unikey = $key; |
67 | utf8::encode $unikey; |
0314122a |
68 | |
3128e575 |
69 | utf8::downgrade $key, 1; |
70 | utf8::downgrade $lckey, 1; |
71 | utf8::downgrade $unikey, 1; |
72 | main_test_inner ($key, $lckey, $unikey, $keys, $description); |
0314122a |
73 | |
3128e575 |
74 | utf8::upgrade $key; |
75 | utf8::upgrade $lckey; |
76 | utf8::upgrade $unikey; |
77 | main_test_inner ($key, $lckey, $unikey, $keys, |
78 | $description . ' [key utf8 on]'); |
79 | } |
0314122a |
80 | |
3128e575 |
81 | # hv_exists was buggy for tied hashes, in that the raw utf8 key was being |
82 | # used - the utf8 flag was being lost. |
83 | perform_test (\&test_absent, (chr 258), $keys, ''); |
0314122a |
84 | |
3128e575 |
85 | perform_test (\&test_fetch_absent, (chr 258), $keys, ''); |
86 | perform_test (\&test_delete_absent, (chr 258), $keys, ''); |
0314122a |
87 | } |
88 | |
3128e575 |
89 | sub main_test_inner { |
90 | my ($key, $lckey, $unikey, $keys, $description) = @_; |
91 | perform_test (\&test_present, $key, $keys, $description); |
92 | perform_test (\&test_fetch_present, $key, $keys, $description); |
93 | perform_test (\&test_delete_present, $key, $keys, $description); |
b60cf05a |
94 | |
3128e575 |
95 | perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']); |
96 | perform_test (\&test_store, $key, $keys, $description, []); |
b60cf05a |
97 | |
3128e575 |
98 | perform_test (\&test_absent, $lckey, $keys, $description); |
99 | perform_test (\&test_fetch_absent, $lckey, $keys, $description); |
100 | perform_test (\&test_delete_absent, $lckey, $keys, $description); |
b60cf05a |
101 | |
3128e575 |
102 | return if $unikey eq $key; |
103 | |
104 | perform_test (\&test_absent, $unikey, $keys, $description); |
105 | perform_test (\&test_fetch_absent, $unikey, $keys, $description); |
106 | perform_test (\&test_delete_absent, $unikey, $keys, $description); |
b60cf05a |
107 | } |
108 | |
3128e575 |
109 | sub perform_test { |
110 | my ($test_sub, $key, $keys, $message, @other) = @_; |
b60cf05a |
111 | my $printable = join ',', map {ord} split //, $key; |
112 | |
3128e575 |
113 | my (%hash, %tiehash); |
114 | tie %tiehash, 'Tie::StdHash'; |
b60cf05a |
115 | |
3128e575 |
116 | @hash{@$keys} = @$keys; |
117 | @tiehash{@$keys} = @$keys; |
b60cf05a |
118 | |
3128e575 |
119 | &$test_sub (\%hash, $key, $printable, $message, @other); |
120 | &$test_sub (\%tiehash, $key, $printable, "$message tie", @other); |
b60cf05a |
121 | } |
122 | |
3128e575 |
123 | sub test_present { |
124 | my ($hash, $key, $printable, $message) = @_; |
125 | |
126 | ok (exists $hash->{$key}, "hv_exists_ent present$message $printable"); |
127 | ok (XS::APItest::Hash::exists ($hash, $key), |
128 | "hv_exists present$message $printable"); |
b60cf05a |
129 | } |
130 | |
3128e575 |
131 | sub test_absent { |
132 | my ($hash, $key, $printable, $message) = @_; |
858117f8 |
133 | |
3128e575 |
134 | ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable"); |
135 | ok (!XS::APItest::Hash::exists ($hash, $key), |
136 | "hv_exists absent$message $printable"); |
b60cf05a |
137 | } |
138 | |
3128e575 |
139 | sub test_delete_present { |
140 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
141 | |
3128e575 |
142 | my $copy = {}; |
143 | my $class = tied %$hash; |
144 | if (defined $class) { |
145 | tie %$copy, ref $class; |
146 | } |
147 | $copy = {%$hash}; |
148 | is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable"); |
149 | $copy = {%$hash}; |
150 | is (XS::APItest::Hash::delete ($copy, $key), $key, |
151 | "hv_delete present$message $printable"); |
b60cf05a |
152 | } |
153 | |
3128e575 |
154 | sub test_delete_absent { |
155 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
156 | |
3128e575 |
157 | my $copy = {}; |
158 | my $class = tied %$hash; |
159 | if (defined $class) { |
160 | tie %$copy, ref $class; |
161 | } |
162 | $copy = {%$hash}; |
163 | is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable"); |
164 | $copy = {%$hash}; |
165 | is (XS::APItest::Hash::delete ($copy, $key), undef, |
166 | "hv_delete absent$message $printable"); |
b60cf05a |
167 | } |
168 | |
3128e575 |
169 | sub test_store { |
170 | my ($hash, $key, $printable, $message, $defaults) = @_; |
171 | my $HV_STORE_IS_CRAZY = 1; |
b60cf05a |
172 | |
3128e575 |
173 | # We are cheating - hv_store returns NULL for a store into an empty |
174 | # tied hash. This isn't helpful here. |
0314122a |
175 | |
3128e575 |
176 | my $class = tied %$hash; |
0314122a |
177 | |
3128e575 |
178 | my %h1 = @$defaults; |
179 | my %h2 = @$defaults; |
180 | if (defined $class) { |
181 | tie %h1, ref $class; |
182 | tie %h2, ref $class; |
183 | $HV_STORE_IS_CRAZY = undef unless @$defaults; |
184 | } |
185 | is (XS::APItest::Hash::store_ent(\%h1, $key, 1), 1, |
186 | "hv_store_ent$message $printable"); |
187 | ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable"); |
188 | is (XS::APItest::Hash::store(\%h2, $key, 1), $HV_STORE_IS_CRAZY, |
189 | "hv_store$message $printable"); |
190 | ok (brute_force_exists (\%h2, $key), "hv_store$message $printable"); |
191 | } |
0314122a |
192 | |
3128e575 |
193 | sub test_fetch_present { |
194 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
195 | |
3128e575 |
196 | is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable"); |
197 | is (XS::APItest::Hash::fetch ($hash, $key), $key, |
198 | "hv_fetch present$message $printable"); |
0314122a |
199 | } |
200 | |
3128e575 |
201 | sub test_fetch_absent { |
202 | my ($hash, $key, $printable, $message) = @_; |
b60cf05a |
203 | |
3128e575 |
204 | is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable"); |
205 | is (XS::APItest::Hash::fetch ($hash, $key), undef, |
206 | "hv_fetch absent$message $printable"); |
207 | } |
b60cf05a |
208 | |
3128e575 |
209 | sub brute_force_exists { |
210 | my ($hash, $key) = @_; |
211 | foreach (keys %$hash) { |
212 | return 1 if $key eq $_; |
213 | } |
214 | return 0; |
b60cf05a |
215 | } |