This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Whoops. We weren't actually testing hv_store_ent
[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 $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;
121   tie %h3, 'Tie::StdHash';
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;
126   tie %h4, 'Tie::StdHash';
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");
130 }
131
132 sub 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
145 sub 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
158 foreach my $key (@testkeys) {
159   test_present ($key);
160   test_fetch_present ($key);
161   test_delete_present ($key);
162
163   test_store ($key, [a=>'cheat']);
164   test_store ($key, []);
165
166   my $lckey = lc $key;
167   test_absent ($lckey);
168   test_fetch_absent ($lckey);
169   test_delete_absent ($lckey);
170
171   my $unikey = $key;
172   utf8::encode $unikey;
173
174   next if $unikey eq $key;
175
176   test_absent ($unikey);
177   test_fetch_absent ($unikey);
178   test_delete_absent ($unikey);
179 }
180
181 # hv_exists was buggy for tied hashes, in that the raw utf8 key was being
182 # used - the utf8 flag was being lost.
183 test_absent (chr 258);
184 test_fetch_absent (chr 258);
185 test_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 }