This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_unsharepvn() was no longer being used in core, and changes to
[perl5.git] / ext / XS / APItest / t / hash.t
CommitLineData
0314122a
NC
1#!perl -w
2
3BEGIN {
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
NC
16use strict;
17use utf8;
0314122a 18use Tie::Hash;
3128e575
NC
19use Test::More 'no_plan';
20
21use_ok('XS::APItest');
0314122a 22
3128e575
NC
23sub preform_test;
24sub test_present;
25sub test_absent;
26sub test_delete_present;
27sub test_delete_absent;
28sub brute_force_exists;
29sub test_store;
30sub test_fetch_present;
31sub test_fetch_absent;
0314122a 32
b60cf05a
NC
33my $utf8_for_258 = chr 258;
34utf8::encode $utf8_for_258;
0314122a 35
3128e575 36my @testkeys = ('N', chr 198, chr 256);
b60cf05a 37my @keys = (@testkeys, $utf8_for_258);
0314122a 38
3128e575
NC
39foreach (@keys) {
40 utf8::downgrade $_, 1;
41}
42main_tests (\@keys, \@testkeys, '');
0314122a 43
3128e575
NC
44foreach (@keys) {
45 utf8::upgrade $_;
46}
47main_tests (\@keys, \@testkeys, ' [utf8 hash]');
0314122a 48
3128e575
NC
49{
50 my %h = (a=>'cheat');
51 tie %h, 'Tie::StdHash';
1baaf5d7 52 is (XS::APItest::Hash::store(\%h, chr 258, 1), undef);
3128e575
NC
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
5d2b1485
NC
58{
59 my $strtab = strtab();
60 is (ref $strtab, 'HASH', "The shared string table quacks like a hash");
8ca60cef 61 my $wibble = "\0";
5d2b1485 62 eval {
8ca60cef 63 $strtab->{$wibble}++;
5d2b1485
NC
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}
2dc92170
NC
85
86{
87 is_deeply([&XS::APItest::Hash::test_hv_free_ent], [2,2,1,1],
88 "hv_free_ent frees the value immediately");
89 is_deeply([&XS::APItest::Hash::test_hv_delayfree_ent], [2,2,2,1],
90 "hv_delayfree_ent keeps the value around until FREETMPS");
91}
35ab5632
NC
92
93foreach my $in ("", "N", "a\0b") {
94 my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
95 is ($got, $in, "test_share_unshare_pvn");
96}
97
3128e575 98exit;
0314122a 99
3128e575 100################################ The End ################################
0314122a 101
3128e575
NC
102sub main_tests {
103 my ($keys, $testkeys, $description) = @_;
104 foreach my $key (@$testkeys) {
105 my $lckey = ($key eq chr 198) ? chr 230 : lc $key;
106 my $unikey = $key;
107 utf8::encode $unikey;
0314122a 108
3128e575
NC
109 utf8::downgrade $key, 1;
110 utf8::downgrade $lckey, 1;
111 utf8::downgrade $unikey, 1;
112 main_test_inner ($key, $lckey, $unikey, $keys, $description);
0314122a 113
3128e575
NC
114 utf8::upgrade $key;
115 utf8::upgrade $lckey;
116 utf8::upgrade $unikey;
117 main_test_inner ($key, $lckey, $unikey, $keys,
118 $description . ' [key utf8 on]');
119 }
0314122a 120
3128e575
NC
121 # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
122 # used - the utf8 flag was being lost.
123 perform_test (\&test_absent, (chr 258), $keys, '');
0314122a 124
3128e575
NC
125 perform_test (\&test_fetch_absent, (chr 258), $keys, '');
126 perform_test (\&test_delete_absent, (chr 258), $keys, '');
0314122a
NC
127}
128
3128e575
NC
129sub main_test_inner {
130 my ($key, $lckey, $unikey, $keys, $description) = @_;
131 perform_test (\&test_present, $key, $keys, $description);
132 perform_test (\&test_fetch_present, $key, $keys, $description);
133 perform_test (\&test_delete_present, $key, $keys, $description);
b60cf05a 134
3128e575
NC
135 perform_test (\&test_store, $key, $keys, $description, [a=>'cheat']);
136 perform_test (\&test_store, $key, $keys, $description, []);
b60cf05a 137
3128e575
NC
138 perform_test (\&test_absent, $lckey, $keys, $description);
139 perform_test (\&test_fetch_absent, $lckey, $keys, $description);
140 perform_test (\&test_delete_absent, $lckey, $keys, $description);
b60cf05a 141
3128e575
NC
142 return if $unikey eq $key;
143
144 perform_test (\&test_absent, $unikey, $keys, $description);
145 perform_test (\&test_fetch_absent, $unikey, $keys, $description);
146 perform_test (\&test_delete_absent, $unikey, $keys, $description);
b60cf05a
NC
147}
148
3128e575
NC
149sub perform_test {
150 my ($test_sub, $key, $keys, $message, @other) = @_;
b60cf05a
NC
151 my $printable = join ',', map {ord} split //, $key;
152
3128e575
NC
153 my (%hash, %tiehash);
154 tie %tiehash, 'Tie::StdHash';
b60cf05a 155
3128e575
NC
156 @hash{@$keys} = @$keys;
157 @tiehash{@$keys} = @$keys;
b60cf05a 158
3128e575
NC
159 &$test_sub (\%hash, $key, $printable, $message, @other);
160 &$test_sub (\%tiehash, $key, $printable, "$message tie", @other);
b60cf05a
NC
161}
162
3128e575
NC
163sub test_present {
164 my ($hash, $key, $printable, $message) = @_;
165
166 ok (exists $hash->{$key}, "hv_exists_ent present$message $printable");
167 ok (XS::APItest::Hash::exists ($hash, $key),
168 "hv_exists present$message $printable");
b60cf05a
NC
169}
170
3128e575
NC
171sub test_absent {
172 my ($hash, $key, $printable, $message) = @_;
858117f8 173
3128e575
NC
174 ok (!exists $hash->{$key}, "hv_exists_ent absent$message $printable");
175 ok (!XS::APItest::Hash::exists ($hash, $key),
176 "hv_exists absent$message $printable");
b60cf05a
NC
177}
178
3128e575
NC
179sub test_delete_present {
180 my ($hash, $key, $printable, $message) = @_;
b60cf05a 181
3128e575
NC
182 my $copy = {};
183 my $class = tied %$hash;
184 if (defined $class) {
185 tie %$copy, ref $class;
186 }
187 $copy = {%$hash};
8829b5e2
NC
188 ok (brute_force_exists ($copy, $key),
189 "hv_delete_ent present$message $printable");
3128e575 190 is (delete $copy->{$key}, $key, "hv_delete_ent present$message $printable");
8829b5e2
NC
191 ok (!brute_force_exists ($copy, $key),
192 "hv_delete_ent present$message $printable");
3128e575 193 $copy = {%$hash};
8829b5e2
NC
194 ok (brute_force_exists ($copy, $key),
195 "hv_delete present$message $printable");
3128e575
NC
196 is (XS::APItest::Hash::delete ($copy, $key), $key,
197 "hv_delete present$message $printable");
8829b5e2
NC
198 ok (!brute_force_exists ($copy, $key),
199 "hv_delete present$message $printable");
b60cf05a
NC
200}
201
3128e575
NC
202sub test_delete_absent {
203 my ($hash, $key, $printable, $message) = @_;
b60cf05a 204
3128e575
NC
205 my $copy = {};
206 my $class = tied %$hash;
207 if (defined $class) {
208 tie %$copy, ref $class;
209 }
210 $copy = {%$hash};
211 is (delete $copy->{$key}, undef, "hv_delete_ent absent$message $printable");
212 $copy = {%$hash};
213 is (XS::APItest::Hash::delete ($copy, $key), undef,
214 "hv_delete absent$message $printable");
b60cf05a
NC
215}
216
3128e575
NC
217sub test_store {
218 my ($hash, $key, $printable, $message, $defaults) = @_;
219 my $HV_STORE_IS_CRAZY = 1;
b60cf05a 220
3128e575
NC
221 # We are cheating - hv_store returns NULL for a store into an empty
222 # tied hash. This isn't helpful here.
0314122a 223
3128e575 224 my $class = tied %$hash;
0314122a 225
3128e575
NC
226 my %h1 = @$defaults;
227 my %h2 = @$defaults;
228 if (defined $class) {
229 tie %h1, ref $class;
230 tie %h2, ref $class;
1baaf5d7 231 $HV_STORE_IS_CRAZY = undef;
3128e575 232 }
1baaf5d7 233 is (XS::APItest::Hash::store_ent(\%h1, $key, 1), $HV_STORE_IS_CRAZY,
3128e575
NC
234 "hv_store_ent$message $printable");
235 ok (brute_force_exists (\%h1, $key), "hv_store_ent$message $printable");
236 is (XS::APItest::Hash::store(\%h2, $key, 1), $HV_STORE_IS_CRAZY,
237 "hv_store$message $printable");
238 ok (brute_force_exists (\%h2, $key), "hv_store$message $printable");
239}
0314122a 240
3128e575
NC
241sub test_fetch_present {
242 my ($hash, $key, $printable, $message) = @_;
b60cf05a 243
3128e575
NC
244 is ($hash->{$key}, $key, "hv_fetch_ent present$message $printable");
245 is (XS::APItest::Hash::fetch ($hash, $key), $key,
246 "hv_fetch present$message $printable");
0314122a
NC
247}
248
3128e575
NC
249sub test_fetch_absent {
250 my ($hash, $key, $printable, $message) = @_;
b60cf05a 251
3128e575
NC
252 is ($hash->{$key}, undef, "hv_fetch_ent absent$message $printable");
253 is (XS::APItest::Hash::fetch ($hash, $key), undef,
254 "hv_fetch absent$message $printable");
255}
b60cf05a 256
3128e575
NC
257sub brute_force_exists {
258 my ($hash, $key) = @_;
259 foreach (keys %$hash) {
260 return 1 if $key eq $_;
261 }
262 return 0;
b60cf05a 263}