Commit | Line | Data |
cf12903c |
1 | BEGIN { |
16421035 |
2 | chdir 't' if -d 't'; |
3 | @INC = '../lib'; |
4 | require Config; import Config; |
5 | if ($Config{'extensions'} !~ /\bXS\/Typemap\b/) { |
6 | print "1..0 # Skip: XS::Typemap was not built\n"; |
7 | exit 0; |
8 | } |
cf12903c |
9 | } |
10 | |
ea035a69 |
11 | use Test; |
5abff6f9 |
12 | BEGIN { plan tests => 84 } |
ea035a69 |
13 | |
14 | use strict; |
15 | use warnings; |
16 | use XS::Typemap; |
17 | |
18 | ok(1); |
19 | |
20 | # Some inheritance trees to check ISA relationships |
21 | BEGIN { |
22 | package intObjPtr::SubClass; |
23 | use base qw/ intObjPtr /; |
24 | sub xxx { 1; } |
25 | } |
26 | |
27 | BEGIN { |
28 | package intRefIvPtr::SubClass; |
29 | use base qw/ intRefIvPtr /; |
30 | sub xxx { 1 } |
31 | } |
32 | |
33 | # T_SV - standard perl scalar value |
34 | print "# T_SV\n"; |
35 | |
36 | my $sv = "Testing T_SV"; |
37 | ok( T_SV($sv), $sv); |
38 | |
39 | # T_SVREF - reference to Scalar |
40 | print "# T_SVREF\n"; |
41 | |
42 | $sv .= "REF"; |
43 | my $svref = \$sv; |
44 | ok( T_SVREF($svref), $svref ); |
45 | |
46 | # Now test that a non reference is rejected |
47 | # the typemaps croak |
48 | eval { T_SVREF( "fail - not ref" ) }; |
49 | ok( $@ ); |
50 | |
51 | # T_AVREF - reference to a perl Array |
52 | print "# T_AVREF\n"; |
53 | |
54 | my @array; |
55 | ok( T_AVREF(\@array), \@array); |
56 | |
57 | # Now test that a non array ref is rejected |
58 | eval { T_AVREF( \$sv ) }; |
59 | ok( $@ ); |
60 | |
61 | # T_HVREF - reference to a perl Hash |
62 | print "# T_HVREF\n"; |
63 | |
64 | my %hash; |
65 | ok( T_HVREF(\%hash), \%hash); |
66 | |
67 | # Now test that a non hash ref is rejected |
68 | eval { T_HVREF( \@array ) }; |
69 | ok( $@ ); |
70 | |
71 | |
72 | # T_CVREF - reference to perl subroutine |
73 | print "# T_CVREF\n"; |
74 | my $sub = sub { 1 }; |
75 | ok( T_CVREF($sub), $sub ); |
76 | |
77 | # Now test that a non code ref is rejected |
78 | eval { T_CVREF( \@array ) }; |
79 | ok( $@ ); |
80 | |
81 | # T_SYSRET - system return values |
82 | print "# T_SYSRET\n"; |
83 | |
84 | # first check success |
85 | ok( T_SYSRET_pass ); |
86 | |
87 | # ... now failure |
88 | ok( T_SYSRET_fail, undef); |
89 | |
90 | # T_UV - unsigned integer |
91 | print "# T_UV\n"; |
92 | |
93 | ok( T_UV(5), 5 ); # pass |
94 | ok( T_UV(-4) != -4); # fail |
95 | |
96 | # T_IV - signed integer |
97 | print "# T_IV\n"; |
98 | |
99 | ok( T_IV(5), 5); |
100 | ok( T_IV(-4), -4); |
101 | ok( T_IV(4.1), int(4.1)); |
102 | ok( T_IV("52"), "52"); |
103 | ok( T_IV(4.5) != 4.5); # failure |
104 | |
105 | |
106 | # Skip T_INT |
107 | |
108 | # T_ENUM - enum list |
109 | print "# T_ENUM\n"; |
110 | |
111 | ok( T_ENUM() ); # just hope for a true value |
112 | |
113 | # T_BOOL - boolean |
114 | print "# T_BOOL\n"; |
115 | |
116 | ok( T_BOOL(52) ); |
117 | ok( ! T_BOOL(0) ); |
118 | ok( ! T_BOOL('') ); |
119 | ok( ! T_BOOL(undef) ); |
120 | |
121 | # Skip T_U_INT |
122 | |
123 | # Skip T_SHORT |
124 | |
125 | # T_U_SHORT aka U16 |
126 | |
127 | print "# T_U_SHORT\n"; |
128 | |
129 | ok( T_U_SHORT(32000), 32000); |
95e35ab6 |
130 | if ($Config{shortsize} == 2) { |
131 | ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases |
132 | } else { |
133 | ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX) |
134 | } |
ea035a69 |
135 | |
136 | # T_U_LONG aka U32 |
137 | |
138 | print "# T_U_LONG\n"; |
139 | |
140 | ok( T_U_LONG(65536), 65536); |
141 | ok( T_U_LONG(-1) != -1); |
142 | |
143 | # T_CHAR |
144 | |
145 | print "# T_CHAR\n"; |
146 | |
147 | ok( T_CHAR("a"), "a"); |
148 | ok( T_CHAR("-"), "-"); |
149 | ok( T_CHAR(chr(128)),chr(128)); |
150 | ok( T_CHAR(chr(256)) ne chr(256)); |
151 | |
152 | # T_U_CHAR |
153 | |
154 | print "# T_U_CHAR\n"; |
155 | |
156 | ok( T_U_CHAR(127), 127); |
157 | ok( T_U_CHAR(128), 128); |
158 | ok( T_U_CHAR(-1) != -1); |
159 | ok( T_U_CHAR(300) != 300); |
160 | |
161 | # T_FLOAT |
162 | print "# T_FLOAT\n"; |
163 | |
164 | # limited precision |
ee37f1e9 |
165 | ok( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345)); |
ea035a69 |
166 | |
167 | # T_NV |
168 | print "# T_NV\n"; |
169 | |
170 | ok( T_NV(52.345), 52.345); |
171 | |
172 | # T_DOUBLE |
173 | print "# T_DOUBLE\n"; |
174 | |
ee37f1e9 |
175 | ok( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345)); |
ea035a69 |
176 | |
177 | # T_PV |
178 | print "# T_PV\n"; |
179 | |
180 | ok( T_PV("a string"), "a string"); |
181 | ok( T_PV(52), 52); |
182 | |
183 | # T_PTR |
184 | print "# T_PTR\n"; |
185 | |
186 | my $t = 5; |
187 | my $ptr = T_PTR_OUT($t); |
188 | ok( T_PTR_IN( $ptr ), $t ); |
189 | |
190 | # T_PTRREF |
191 | print "# T_PTRREF\n"; |
192 | |
193 | $t = -52; |
194 | $ptr = T_PTRREF_OUT( $t ); |
195 | ok( ref($ptr), "SCALAR"); |
196 | ok( T_PTRREF_IN( $ptr ), $t ); |
197 | |
198 | # test that a non-scalar ref is rejected |
199 | eval { T_PTRREF_IN( $t ); }; |
200 | ok( $@ ); |
201 | |
202 | # T_PTROBJ |
203 | print "# T_PTROBJ\n"; |
204 | |
205 | $t = 256; |
206 | $ptr = T_PTROBJ_OUT( $t ); |
207 | ok( ref($ptr), "intObjPtr"); |
208 | ok( $ptr->T_PTROBJ_IN, $t ); |
209 | |
210 | # check that normal scalar refs fail |
211 | eval {intObjPtr::T_PTROBJ_IN( \$t );}; |
212 | ok( $@ ); |
213 | |
214 | # check that inheritance works |
215 | bless $ptr, "intObjPtr::SubClass"; |
216 | ok( ref($ptr), "intObjPtr::SubClass"); |
217 | ok( $ptr->T_PTROBJ_IN, $t ); |
218 | |
219 | # Skip T_REF_IV_REF |
220 | |
221 | # T_REF_IV_PTR |
222 | print "# T_REF_IV_PTR\n"; |
223 | |
224 | $t = -365; |
225 | $ptr = T_REF_IV_PTR_OUT( $t ); |
226 | ok( ref($ptr), "intRefIvPtr"); |
227 | ok( $ptr->T_REF_IV_PTR_IN(), $t); |
228 | |
229 | # inheritance should not work |
230 | bless $ptr, "intRefIvPtr::SubClass"; |
231 | eval { $ptr->T_REF_IV_PTR_IN }; |
232 | ok( $@ ); |
233 | |
234 | # Skip T_PTRDESC |
235 | |
236 | # Skip T_REFREF |
237 | |
238 | # Skip T_REFOBJ |
239 | |
240 | # T_OPAQUEPTR |
241 | print "# T_OPAQUEPTR\n"; |
242 | |
243 | $t = 22; |
5abff6f9 |
244 | my $p = T_OPAQUEPTR_IN( $t ); |
245 | ok( T_OPAQUEPTR_OUT($p), $t); |
246 | |
247 | # T_OPAQUEPTR with a struct |
248 | print "# T_OPAQUEPTR with a struct\n"; |
249 | |
250 | my @test = (5,6,7); |
251 | $p = T_OPAQUEPTR_IN_struct(@test); |
252 | my @result = T_OPAQUEPTR_OUT_struct($p); |
253 | ok(scalar(@result),scalar(@test)); |
254 | for (0..$#test) { |
255 | ok($result[$_], $test[$_]); |
256 | } |
ea035a69 |
257 | |
258 | # T_OPAQUE |
259 | print "# T_OPAQUE\n"; |
260 | |
261 | $t = 48; |
5abff6f9 |
262 | $p = T_OPAQUE_IN( $t ); |
263 | ok(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR |
264 | ok(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE |
ea035a69 |
265 | |
266 | # T_OPAQUE_array |
5abff6f9 |
267 | print "# A packed array\n"; |
268 | |
ea035a69 |
269 | my @opq = (2,4,8); |
270 | my $packed = T_OPAQUE_array(@opq); |
271 | my @uopq = unpack("i*",$packed); |
5abff6f9 |
272 | ok(scalar(@uopq), scalar(@opq)); |
ea035a69 |
273 | for (0..$#opq) { |
274 | ok( $uopq[$_], $opq[$_]); |
275 | } |
276 | |
277 | # Skip T_PACKED |
278 | |
279 | # Skip T_PACKEDARRAY |
280 | |
281 | # Skip T_DATAUNIT |
282 | |
283 | # Skip T_CALLBACK |
284 | |
285 | # T_ARRAY |
286 | print "# T_ARRAY\n"; |
287 | my @inarr = (1,2,3,4,5,6,7,8,9,10); |
288 | my @outarr = T_ARRAY( 5, @inarr ); |
289 | ok(scalar(@outarr), scalar(@inarr)); |
290 | |
291 | for (0..$#inarr) { |
292 | ok($outarr[$_], $inarr[$_]); |
293 | } |
294 | |
295 | |
296 | |
297 | # T_STDIO |
298 | print "# T_STDIO\n"; |
299 | |
300 | # open a file in XS for write |
301 | my $testfile= "stdio.tmp"; |
302 | my $fh = T_STDIO_open( $testfile ); |
303 | ok( $fh ); |
304 | |
305 | # write to it using perl |
306 | if (defined $fh) { |
307 | |
308 | my @lines = ("NormalSTDIO\n", "PerlIO\n"); |
309 | |
310 | # print to it using FILE* through XS |
311 | ok( T_STDIO_print($fh, $lines[0]), length($lines[0])); |
312 | |
313 | # print to it using normal perl |
314 | ok(print $fh "$lines[1]"); |
315 | |
b9735fbe |
316 | # close it using XS if using perlio, using Perl otherwise |
317 | ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) ); |
ea035a69 |
318 | |
319 | # open from perl, and check contents |
320 | open($fh, "< $testfile"); |
321 | ok($fh); |
322 | my $line = <$fh>; |
323 | ok($line,$lines[0]); |
324 | $line = <$fh>; |
325 | ok($line,$lines[1]); |
326 | |
327 | ok(close($fh)); |
328 | ok(unlink($testfile)); |
329 | |
330 | } else { |
331 | for (1..8) { |
332 | skip("Skip Test not relevant since file was not opened correctly",0); |
333 | } |
334 | } |
335 | |