This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Shift negative klen/flags games from hv_fetch_common out to hv_fetch
[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
16use Tie::Hash;
17
18my @testkeys = ('N', chr 256);
19
b60cf05a
NC
20my $utf8_for_258 = chr 258;
21utf8::encode $utf8_for_258;
0314122a 22
b60cf05a 23my @keys = (@testkeys, $utf8_for_258);
0314122a
NC
24my (%hash, %tiehash);
25tie %tiehash, 'Tie::StdHash';
26
b60cf05a
NC
27@hash{@keys} = @keys;
28@tiehash{@keys} = @keys;
0314122a
NC
29
30
31use Test::More 'no_plan';
32
33use_ok('XS::APItest');
34
35sub 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
47sub 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
NC
59sub 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
79sub 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
99sub brute_force_exists {
100 my ($hash, $key) = @_;
101 foreach (keys %$hash) {
102 return 1 if $key eq $_;
103 }
104 return 0;
105}
106
107sub test_store {
108 my $key = shift;
858117f8
NC
109 my $defaults = shift;
110 my $HV_STORE_IS_CRAZY = @$defaults ? 1 : undef;
111 my $name = join ',', map {ord} split //, $key;
112 $name .= ' (hash starts empty)' unless @$defaults;
113
114 my %h1 = @$defaults;
115 is (XS::APItest::Hash::store_ent (\%h1, $key, 1), 1, "hv_store_ent $name");
116 ok (brute_force_exists (\%h1, $key), "hv_store_ent $name");
117 my %h2 = @$defaults;
118 is (XS::APItest::Hash::store(\%h2, $key, 1), 1, "hv_store $name");
119 ok (brute_force_exists (\%h2, $key), "hv_store $name");
120 my %h3 = @$defaults;
b60cf05a 121 tie %h3, 'Tie::StdHash';
858117f8
NC
122 is (XS::APItest::Hash::store_ent (\%h3, $key, 1), 1,
123 "hv_store_ent tie $name");
124 ok (brute_force_exists (\%h3, $key), "hv_store_ent tie $name");
125 my %h4 = @$defaults;
b60cf05a 126 tie %h4, 'Tie::StdHash';
858117f8
NC
127 is (XS::APItest::Hash::store(\%h4, $key, 1), $HV_STORE_IS_CRAZY,
128 "hv_store tie $name");
129 ok (brute_force_exists (\%h4, $key), "hv_store tie $name");
b60cf05a
NC
130}
131
132sub test_fetch_present {
133 my $key = shift;
134 my $printable = join ',', map {ord} split //, $key;
135
136 is ($hash{$key}, $key, "hv_fetch_ent present $printable");
137 is (XS::APItest::Hash::fetch (\%hash, $key), $key,
138 "hv_fetch present $printable");
139
140 is ($tiehash{$key}, $key, "hv_fetch_ent tie present $printable");
141 is (XS::APItest::Hash::fetch (\%tiehash, $key), $key,
142 "hv_fetch tie present $printable");
143}
144
145sub test_fetch_absent {
146 my $key = shift;
147 my $printable = join ',', map {ord} split //, $key;
148
149 is ($hash{$key}, undef, "hv_fetch_ent absent $printable");
150 is (XS::APItest::Hash::fetch (\%hash, $key), undef,
151 "hv_fetch absent $printable");
152
153 is ($tiehash{$key}, undef, "hv_fetch_ent tie absent $printable");
154 is (XS::APItest::Hash::fetch (\%tiehash, $key), undef,
155 "hv_fetch tie absent $printable");
156}
157
0314122a
NC
158foreach my $key (@testkeys) {
159 test_present ($key);
b60cf05a
NC
160 test_fetch_present ($key);
161 test_delete_present ($key);
162
858117f8
NC
163 test_store ($key, [a=>'cheat']);
164 test_store ($key, []);
0314122a
NC
165
166 my $lckey = lc $key;
167 test_absent ($lckey);
b60cf05a
NC
168 test_fetch_absent ($lckey);
169 test_delete_absent ($lckey);
0314122a
NC
170
171 my $unikey = $key;
172 utf8::encode $unikey;
173
b60cf05a
NC
174 next if $unikey eq $key;
175
176 test_absent ($unikey);
177 test_fetch_absent ($unikey);
178 test_delete_absent ($unikey);
0314122a
NC
179}
180
b60cf05a
NC
181# hv_exists was buggy for tied hashes, in that the raw utf8 key was being
182# used - the utf8 flag was being lost.
0314122a 183test_absent (chr 258);
b60cf05a
NC
184test_fetch_absent (chr 258);
185test_delete_absent (chr 258);
186
187{
188 my %h = (a=>'cheat');
189 tie %h, 'Tie::StdHash';
190 is (XS::APItest::Hash::store(\%h, chr 258, 1), 1);
191
192 ok (!exists $h{$utf8_for_258},
193 "hv_store doesn't insert a key with the raw utf8 on a tied hash");
194}