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