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 | |
16 | use Tie::Hash; |
17 | |
18 | my @testkeys = ('N', chr 256); |
19 | |
b60cf05a |
20 | my $utf8_for_258 = chr 258; |
21 | utf8::encode $utf8_for_258; |
0314122a |
22 | |
b60cf05a |
23 | my @keys = (@testkeys, $utf8_for_258); |
0314122a |
24 | my (%hash, %tiehash); |
25 | tie %tiehash, 'Tie::StdHash'; |
26 | |
b60cf05a |
27 | @hash{@keys} = @keys; |
28 | @tiehash{@keys} = @keys; |
0314122a |
29 | |
30 | |
31 | use Test::More 'no_plan'; |
32 | |
33 | use_ok('XS::APItest'); |
34 | |
35 | sub test_present { |
36 | my $key = shift; |
37 | my $printable = join ',', map {ord} split //, $key; |
38 | |
39 | ok (exists $hash{$key}, "hv_exists_ent present $printable"); |
40 | ok (XS::APItest::Hash::exists (\%hash, $key), "hv_exists present $printable"); |
41 | |
42 | ok (exists $tiehash{$key}, "hv_exists_ent tie present $printable"); |
43 | ok (XS::APItest::Hash::exists (\%tiehash, $key), |
44 | "hv_exists tie present $printable"); |
45 | } |
46 | |
47 | sub test_absent { |
48 | my $key = shift; |
49 | my $printable = join ',', map {ord} split //, $key; |
50 | |
51 | ok (!exists $hash{$key}, "hv_exists_ent absent $printable"); |
52 | ok (!XS::APItest::Hash::exists (\%hash, $key), "hv_exists absent $printable"); |
53 | |
54 | ok (!exists $tiehash{$key}, "hv_exists_ent tie absent $printable"); |
55 | ok (!XS::APItest::Hash::exists (\%tiehash, $key), |
56 | "hv_exists tie absent $printable"); |
57 | } |
58 | |
b60cf05a |
59 | sub test_delete_present { |
60 | my $key = shift; |
61 | my $printable = join ',', map {ord} split //, $key; |
62 | |
63 | my $copy = {%hash}; |
64 | is (delete $copy->{$key}, $key, "hv_delete_ent present $printable"); |
65 | $copy = {%hash}; |
66 | is (XS::APItest::Hash::delete ($copy, $key), $key, |
67 | "hv_delete present $printable"); |
68 | |
69 | $copy = {}; |
70 | tie %$copy, 'Tie::StdHash'; |
71 | %$copy = %tiehash; |
72 | is (delete $copy->{$key}, $key, "hv_delete_ent tie present $printable"); |
73 | |
74 | %$copy = %tiehash; |
75 | is (XS::APItest::Hash::delete ($copy, $key), $key, |
76 | "hv_delete tie present $printable"); |
77 | } |
78 | |
79 | sub test_delete_absent { |
80 | my $key = shift; |
81 | my $printable = join ',', map {ord} split //, $key; |
82 | |
83 | my $copy = {%hash}; |
84 | is (delete $copy->{$key}, undef, "hv_delete_ent absent $printable"); |
85 | $copy = {%hash}; |
86 | is (XS::APItest::Hash::delete ($copy, $key), undef, |
87 | "hv_delete absent $printable"); |
88 | |
89 | $copy = {}; |
90 | tie %$copy, 'Tie::StdHash'; |
91 | %$copy = %tiehash; |
92 | is (delete $copy->{$key}, undef, "hv_delete_ent tie absent $printable"); |
93 | |
94 | %$copy = %tiehash; |
95 | is (XS::APItest::Hash::delete ($copy, $key), undef, |
96 | "hv_delete tie absent $printable"); |
97 | } |
98 | |
99 | sub brute_force_exists { |
100 | my ($hash, $key) = @_; |
101 | foreach (keys %$hash) { |
102 | return 1 if $key eq $_; |
103 | } |
104 | return 0; |
105 | } |
106 | |
107 | sub test_store { |
108 | my $key = shift; |
109 | my $printable = join ',', map {ord} split //, $key; |
110 | |
111 | # We are cheating - hv_store returns NULL for a store into an empty |
112 | # tied hash. This isn't helpful here. |
113 | |
114 | my %h1 = (a=>'cheat'); |
115 | is ($h1{$key} = 1, 1); |
116 | ok (brute_force_exists (\%h1, $key), "hv_store_ent $printable"); |
117 | my %h2 = (a=>'cheat'); |
118 | is (XS::APItest::Hash::store(\%h2, $key, 1), 1); |
119 | ok (brute_force_exists (\%h2, $key), "hv_store $printable"); |
120 | my %h3 = (a=>'cheat'); |
121 | tie %h3, 'Tie::StdHash'; |
122 | is ($h3{$key} = 1, 1); |
123 | ok (brute_force_exists (\%h3, $key), "hv_store_ent tie $printable"); |
124 | |
125 | my %h4 = (a=>'cheat'); |
126 | tie %h4, 'Tie::StdHash'; |
127 | is (XS::APItest::Hash::store(\%h4, $key, 1), 1); |
128 | ok (brute_force_exists (\%h4, $key), "hv_store tie $printable"); |
129 | } |
130 | |
131 | sub test_fetch_present { |
132 | my $key = shift; |
133 | my $printable = join ',', map {ord} split //, $key; |
134 | |
135 | is ($hash{$key}, $key, "hv_fetch_ent present $printable"); |
136 | is (XS::APItest::Hash::fetch (\%hash, $key), $key, |
137 | "hv_fetch present $printable"); |
138 | |
139 | is ($tiehash{$key}, $key, "hv_fetch_ent tie present $printable"); |
140 | is (XS::APItest::Hash::fetch (\%tiehash, $key), $key, |
141 | "hv_fetch tie present $printable"); |
142 | } |
143 | |
144 | sub test_fetch_absent { |
145 | my $key = shift; |
146 | my $printable = join ',', map {ord} split //, $key; |
147 | |
148 | is ($hash{$key}, undef, "hv_fetch_ent absent $printable"); |
149 | is (XS::APItest::Hash::fetch (\%hash, $key), undef, |
150 | "hv_fetch absent $printable"); |
151 | |
152 | is ($tiehash{$key}, undef, "hv_fetch_ent tie absent $printable"); |
153 | is (XS::APItest::Hash::fetch (\%tiehash, $key), undef, |
154 | "hv_fetch tie absent $printable"); |
155 | } |
156 | |
0314122a |
157 | foreach my $key (@testkeys) { |
158 | test_present ($key); |
b60cf05a |
159 | test_fetch_present ($key); |
160 | test_delete_present ($key); |
161 | |
162 | test_store ($key); |
0314122a |
163 | |
164 | my $lckey = lc $key; |
165 | test_absent ($lckey); |
b60cf05a |
166 | test_fetch_absent ($lckey); |
167 | test_delete_absent ($lckey); |
0314122a |
168 | |
169 | my $unikey = $key; |
170 | utf8::encode $unikey; |
171 | |
b60cf05a |
172 | next if $unikey eq $key; |
173 | |
174 | test_absent ($unikey); |
175 | test_fetch_absent ($unikey); |
176 | test_delete_absent ($unikey); |
0314122a |
177 | } |
178 | |
b60cf05a |
179 | # hv_exists was buggy for tied hashes, in that the raw utf8 key was being |
180 | # used - the utf8 flag was being lost. |
0314122a |
181 | test_absent (chr 258); |
b60cf05a |
182 | test_fetch_absent (chr 258); |
183 | test_delete_absent (chr 258); |
184 | |
185 | { |
186 | my %h = (a=>'cheat'); |
187 | tie %h, 'Tie::StdHash'; |
188 | is (XS::APItest::Hash::store(\%h, chr 258, 1), 1); |
189 | |
190 | ok (!exists $h{$utf8_for_258}, |
191 | "hv_store doesn't insert a key with the raw utf8 on a tied hash"); |
192 | } |