This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2a2a4e027b2b9fc517bd97f002fc158875ba38e0
[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 Tie::Hash;
17
18 my @testkeys = ('N', chr 256);
19
20 my $utf8_for_258 = chr 258;
21 utf8::encode $utf8_for_258;
22
23 my @keys = (@testkeys, $utf8_for_258);
24 my (%hash, %tiehash);
25 tie %tiehash, 'Tie::StdHash';
26
27 @hash{@keys} = @keys;
28 @tiehash{@keys} = @keys;
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
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
157 foreach my $key (@testkeys) {
158   test_present ($key);
159   test_fetch_present ($key);
160   test_delete_present ($key);
161
162   test_store ($key);
163
164   my $lckey = lc $key;
165   test_absent ($lckey);
166   test_fetch_absent ($lckey);
167   test_delete_absent ($lckey);
168
169   my $unikey = $key;
170   utf8::encode $unikey;
171
172   next if $unikey eq $key;
173
174   test_absent ($unikey);
175   test_fetch_absent ($unikey);
176   test_delete_absent ($unikey);
177 }
178
179 # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
180 # used - the utf8 flag was being lost.
181 test_absent (chr 258);
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 }