Commit | Line | Data |
---|---|---|
cf12903c | 1 | BEGIN { |
16421035 PP |
2 | require Config; import Config; |
3 | if ($Config{'extensions'} !~ /\bXS\/Typemap\b/) { | |
4 | print "1..0 # Skip: XS::Typemap was not built\n"; | |
5 | exit 0; | |
6 | } | |
cf12903c JH |
7 | } |
8 | ||
4f62cd62 | 9 | use Test::More tests => 148; |
ea035a69 JH |
10 | |
11 | use strict; | |
12 | use warnings; | |
13 | use XS::Typemap; | |
14 | ||
8618896a | 15 | pass(); |
ea035a69 JH |
16 | |
17 | # Some inheritance trees to check ISA relationships | |
18 | BEGIN { | |
19 | package intObjPtr::SubClass; | |
af23c902 | 20 | use parent '-norequire', qw/ intObjPtr /; |
ea035a69 JH |
21 | sub xxx { 1; } |
22 | } | |
23 | ||
24 | BEGIN { | |
25 | package intRefIvPtr::SubClass; | |
af23c902 | 26 | use parent '-norequire', qw/ intRefIvPtr /; |
ea035a69 JH |
27 | sub xxx { 1 } |
28 | } | |
29 | ||
30 | # T_SV - standard perl scalar value | |
dcea22eb | 31 | note("T_SV"); |
ea035a69 | 32 | my $sv = "Testing T_SV"; |
8618896a | 33 | is( T_SV($sv), $sv); |
ea035a69 JH |
34 | |
35 | # T_SVREF - reference to Scalar | |
dcea22eb | 36 | note("T_SVREF"); |
ea035a69 JH |
37 | $sv .= "REF"; |
38 | my $svref = \$sv; | |
8618896a | 39 | is( T_SVREF($svref), $svref ); |
dcea22eb | 40 | is( ${ T_SVREF($svref) }, $$svref ); |
ea035a69 JH |
41 | |
42 | # Now test that a non reference is rejected | |
43 | # the typemaps croak | |
44 | eval { T_SVREF( "fail - not ref" ) }; | |
45 | ok( $@ ); | |
46 | ||
dcea22eb | 47 | note("T_SVREF_REFCOUNT_FIXED"); |
1d2615b4 | 48 | is( T_SVREF_REFCOUNT_FIXED($svref), $svref ); |
dcea22eb | 49 | is( ${ T_SVREF_REFCOUNT_FIXED($svref) }, $$svref ); |
1d2615b4 S |
50 | eval { T_SVREF_REFCOUNT_FIXED( "fail - not ref" ) }; |
51 | ok( $@ ); | |
52 | ||
b64f48ff | 53 | |
ea035a69 | 54 | # T_AVREF - reference to a perl Array |
dcea22eb | 55 | note("T_AVREF"); |
ea035a69 | 56 | my @array; |
8618896a | 57 | is( T_AVREF(\@array), \@array); |
ea035a69 JH |
58 | # Now test that a non array ref is rejected |
59 | eval { T_AVREF( \$sv ) }; | |
60 | ok( $@ ); | |
61 | ||
b64f48ff | 62 | # T_AVREF_REFCOUNT_FIXED - reference to a perl Array, refcount fixed |
dcea22eb | 63 | note("T_AVREF_REFCOUNT_FIXED"); |
b64f48ff | 64 | is( T_AVREF_REFCOUNT_FIXED(\@array), \@array); |
b64f48ff S |
65 | # Now test that a non array ref is rejected |
66 | eval { T_AVREF_REFCOUNT_FIXED( \$sv ) }; | |
67 | ok( $@ ); | |
68 | ||
69 | ||
ea035a69 | 70 | # T_HVREF - reference to a perl Hash |
dcea22eb | 71 | note("T_HVREF"); |
ea035a69 | 72 | my %hash; |
8618896a | 73 | is( T_HVREF(\%hash), \%hash); |
ea035a69 JH |
74 | # Now test that a non hash ref is rejected |
75 | eval { T_HVREF( \@array ) }; | |
76 | ok( $@ ); | |
77 | ||
78 | ||
b64f48ff | 79 | # T_HVREF_REFCOUNT_FIXED - reference to a perl Hash, refcount fixed |
dcea22eb | 80 | note("T_HVREF_REFCOUNT_FIXED"); |
b64f48ff | 81 | is( T_HVREF_REFCOUNT_FIXED(\%hash), \%hash); |
b64f48ff S |
82 | # Now test that a non hash ref is rejected |
83 | eval { T_HVREF_REFCOUNT_FIXED( \@array ) }; | |
84 | ok( $@ ); | |
85 | ||
86 | ||
ea035a69 | 87 | # T_CVREF - reference to perl subroutine |
dcea22eb | 88 | note("T_CVREF"); |
ea035a69 | 89 | my $sub = sub { 1 }; |
8618896a | 90 | is( T_CVREF($sub), $sub ); |
ea035a69 JH |
91 | # Now test that a non code ref is rejected |
92 | eval { T_CVREF( \@array ) }; | |
93 | ok( $@ ); | |
94 | ||
1d2615b4 | 95 | is( T_CVREF_REFCOUNT_FIXED($sub), $sub ); |
1d2615b4 S |
96 | # Now test that a non code ref is rejected |
97 | eval { T_CVREF_REFCOUNT_FIXED( \@array ) }; | |
98 | ok( $@ ); | |
99 | ||
100 | ||
ea035a69 | 101 | # T_SYSRET - system return values |
dcea22eb | 102 | note("T_SYSRET"); |
ea035a69 JH |
103 | # first check success |
104 | ok( T_SYSRET_pass ); | |
ea035a69 | 105 | # ... now failure |
8618896a | 106 | is( T_SYSRET_fail, undef); |
ea035a69 JH |
107 | |
108 | # T_UV - unsigned integer | |
dcea22eb | 109 | note("T_UV"); |
8618896a NC |
110 | is( T_UV(5), 5 ); # pass |
111 | isnt( T_UV(-4), -4); # fail | |
ea035a69 | 112 | |
604db645 S |
113 | # T_U_INT - unsigned integer with (unsigned int) cast |
114 | note("T_U_INT"); | |
115 | is( T_U_INT(5), 5 ); # pass | |
116 | isnt( T_U_INT(-4), -4); # fail | |
ea035a69 | 117 | |
604db645 S |
118 | # T_IV - signed integer |
119 | # T_INT - signed integer with cast | |
120 | # T_LONG - signed integer with cast to IV | |
121 | # T_SHORT - signed short | |
122 | for my $t (['T_IV', \&T_IV], | |
123 | ['T_INT', \&T_INT], | |
124 | ['T_LONG', \&T_LONG], | |
125 | ['T_SHORT', \&T_SHORT]) | |
126 | { | |
127 | note($t->[0]); | |
128 | is( $t->[1]->(5), 5); | |
129 | is( $t->[1]->(-4), -4); | |
130 | is( $t->[1]->(4.1), int(4.1)); | |
131 | is( $t->[1]->("52"), "52"); | |
132 | isnt( $t->[1]->(4.5), 4.5); # failure | |
133 | } | |
ea035a69 | 134 | |
604db645 S |
135 | if ($Config{shortsize} == 2) { |
136 | isnt( T_SHORT(32801), 32801 ); | |
137 | } | |
138 | else { | |
139 | pass(); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX) | |
140 | } | |
ea035a69 JH |
141 | |
142 | # T_ENUM - enum list | |
dcea22eb | 143 | ok( T_ENUM(), 'T_ENUM' ); # just hope for a true value |
ea035a69 JH |
144 | |
145 | # T_BOOL - boolean | |
dcea22eb | 146 | note("T_BOOL"); |
ea035a69 JH |
147 | |
148 | ok( T_BOOL(52) ); | |
149 | ok( ! T_BOOL(0) ); | |
150 | ok( ! T_BOOL('') ); | |
151 | ok( ! T_BOOL(undef) ); | |
152 | ||
a14f212e TC |
153 | { |
154 | # these attempt to modify a read-only value | |
a14f212e TC |
155 | ok( !eval { T_BOOL_2(52); 1 } ); |
156 | ok( !eval { T_BOOL_2(0); 1 } ); | |
157 | ok( !eval { T_BOOL_2(''); 1 } ); | |
158 | ok( !eval { T_BOOL_2(undef); 1 } ); | |
159 | } | |
742aa4c0 | 160 | |
b0bbf760 DD |
161 | { |
162 | my ($in, $out); | |
163 | $in = 1; | |
164 | T_BOOL_OUT($out, $in); | |
165 | ok($out, "T_BOOL_OUT, true in"); | |
166 | $in = 0; | |
85b59111 | 167 | $out = 1; |
b0bbf760 DD |
168 | T_BOOL_OUT($out, $in); |
169 | ok(!$out, "T_BOOL_OUT, false in"); | |
170 | } | |
171 | ||
ea035a69 | 172 | # T_U_SHORT aka U16 |
dcea22eb | 173 | note("T_U_SHORT"); |
8618896a | 174 | is( T_U_SHORT(32000), 32000); |
95e35ab6 | 175 | if ($Config{shortsize} == 2) { |
8618896a | 176 | isnt( T_U_SHORT(65536), 65536); # probably dont want to test edge cases |
95e35ab6 JH |
177 | } else { |
178 | ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX) | |
179 | } | |
ea035a69 JH |
180 | |
181 | # T_U_LONG aka U32 | |
dcea22eb | 182 | note("T_U_LONG"); |
8618896a NC |
183 | is( T_U_LONG(65536), 65536); |
184 | isnt( T_U_LONG(-1), -1); | |
ea035a69 JH |
185 | |
186 | # T_CHAR | |
dcea22eb | 187 | note("T_CHAR"); |
8618896a NC |
188 | is( T_CHAR("a"), "a"); |
189 | is( T_CHAR("-"), "-"); | |
190 | is( T_CHAR(chr(128)),chr(128)); | |
191 | isnt( T_CHAR(chr(256)), chr(256)); | |
ea035a69 JH |
192 | |
193 | # T_U_CHAR | |
dcea22eb | 194 | note("T_U_CHAR"); |
8618896a NC |
195 | is( T_U_CHAR(127), 127); |
196 | is( T_U_CHAR(128), 128); | |
197 | isnt( T_U_CHAR(-1), -1); | |
198 | isnt( T_U_CHAR(300), 300); | |
ea035a69 JH |
199 | |
200 | # T_FLOAT | |
ea035a69 | 201 | # limited precision |
dcea22eb | 202 | is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345), "T_FLOAT"); |
ea035a69 JH |
203 | |
204 | # T_NV | |
dcea22eb | 205 | is( T_NV(52.345), 52.345, "T_NV" ); |
ea035a69 JH |
206 | |
207 | # T_DOUBLE | |
dcea22eb | 208 | is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345), "T_DOUBLE" ); |
ea035a69 JH |
209 | |
210 | # T_PV | |
dcea22eb | 211 | note("T_PV"); |
8618896a NC |
212 | is( T_PV("a string"), "a string"); |
213 | is( T_PV(52), 52); | |
4f62cd62 FC |
214 | ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*'; |
215 | { | |
216 | my $uninit; | |
217 | local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ }; | |
218 | () = ''.T_PV_null; | |
219 | is $uninit, 1, 'uninit warning from NULL returned from char* func'; | |
220 | } | |
ea035a69 JH |
221 | |
222 | # T_PTR | |
ea035a69 JH |
223 | my $t = 5; |
224 | my $ptr = T_PTR_OUT($t); | |
dcea22eb | 225 | is( T_PTR_IN( $ptr ), $t, "T_PTR" ); |
ea035a69 JH |
226 | |
227 | # T_PTRREF | |
dcea22eb | 228 | note("T_PTRREF"); |
ea035a69 JH |
229 | $t = -52; |
230 | $ptr = T_PTRREF_OUT( $t ); | |
8618896a NC |
231 | is( ref($ptr), "SCALAR"); |
232 | is( T_PTRREF_IN( $ptr ), $t ); | |
ea035a69 JH |
233 | |
234 | # test that a non-scalar ref is rejected | |
235 | eval { T_PTRREF_IN( $t ); }; | |
236 | ok( $@ ); | |
237 | ||
238 | # T_PTROBJ | |
dcea22eb | 239 | note("T_PTROBJ"); |
ea035a69 JH |
240 | $t = 256; |
241 | $ptr = T_PTROBJ_OUT( $t ); | |
8618896a NC |
242 | is( ref($ptr), "intObjPtr"); |
243 | is( $ptr->T_PTROBJ_IN, $t ); | |
ea035a69 JH |
244 | |
245 | # check that normal scalar refs fail | |
246 | eval {intObjPtr::T_PTROBJ_IN( \$t );}; | |
247 | ok( $@ ); | |
248 | ||
249 | # check that inheritance works | |
250 | bless $ptr, "intObjPtr::SubClass"; | |
8618896a NC |
251 | is( ref($ptr), "intObjPtr::SubClass"); |
252 | is( $ptr->T_PTROBJ_IN, $t ); | |
ea035a69 JH |
253 | |
254 | # Skip T_REF_IV_REF | |
255 | ||
256 | # T_REF_IV_PTR | |
dcea22eb | 257 | note("T_REF_IV_PTR"); |
ea035a69 JH |
258 | $t = -365; |
259 | $ptr = T_REF_IV_PTR_OUT( $t ); | |
8618896a NC |
260 | is( ref($ptr), "intRefIvPtr"); |
261 | is( $ptr->T_REF_IV_PTR_IN(), $t); | |
ea035a69 JH |
262 | |
263 | # inheritance should not work | |
264 | bless $ptr, "intRefIvPtr::SubClass"; | |
265 | eval { $ptr->T_REF_IV_PTR_IN }; | |
266 | ok( $@ ); | |
267 | ||
268 | # Skip T_PTRDESC | |
269 | ||
270 | # Skip T_REFREF | |
271 | ||
272 | # Skip T_REFOBJ | |
273 | ||
274 | # T_OPAQUEPTR | |
dcea22eb | 275 | note("T_OPAQUEPTR"); |
ea035a69 | 276 | $t = 22; |
5abff6f9 | 277 | my $p = T_OPAQUEPTR_IN( $t ); |
8618896a | 278 | is( T_OPAQUEPTR_OUT($p), $t); |
5abff6f9 TJ |
279 | |
280 | # T_OPAQUEPTR with a struct | |
dcea22eb | 281 | note("T_OPAQUEPTR with a struct"); |
5abff6f9 TJ |
282 | my @test = (5,6,7); |
283 | $p = T_OPAQUEPTR_IN_struct(@test); | |
284 | my @result = T_OPAQUEPTR_OUT_struct($p); | |
8618896a | 285 | is(scalar(@result),scalar(@test)); |
5abff6f9 | 286 | for (0..$#test) { |
8618896a | 287 | is($result[$_], $test[$_]); |
5abff6f9 | 288 | } |
ea035a69 JH |
289 | |
290 | # T_OPAQUE | |
dcea22eb | 291 | note("T_OPAQUE"); |
ea035a69 | 292 | $t = 48; |
5abff6f9 | 293 | $p = T_OPAQUE_IN( $t ); |
8618896a NC |
294 | is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR |
295 | is(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE | |
ea035a69 JH |
296 | |
297 | # T_OPAQUE_array | |
2465d83f | 298 | note("T_OPAQUE: A packed array"); |
5abff6f9 | 299 | |
ea035a69 JH |
300 | my @opq = (2,4,8); |
301 | my $packed = T_OPAQUE_array(@opq); | |
302 | my @uopq = unpack("i*",$packed); | |
8618896a | 303 | is(scalar(@uopq), scalar(@opq)); |
ea035a69 | 304 | for (0..$#opq) { |
8618896a | 305 | is( $uopq[$_], $opq[$_]); |
ea035a69 JH |
306 | } |
307 | ||
2465d83f S |
308 | # T_PACKED |
309 | note("T_PACKED"); | |
310 | my $struct = T_PACKED_out(-4, 3, 2.1); | |
311 | ok(ref($struct) eq 'HASH'); | |
864fd8d3 S |
312 | is_approx($struct->{a}, -4); |
313 | is_approx($struct->{b}, 3); | |
314 | is_approx($struct->{c}, 2.1); | |
2465d83f | 315 | my @rv = T_PACKED_in($struct); |
864fd8d3 S |
316 | is(scalar(@rv), 3); |
317 | is_approx($rv[0], -4); | |
318 | is_approx($rv[1], 3); | |
319 | is_approx($rv[2], 2.1); | |
ea035a69 | 320 | |
ea0d3d8e S |
321 | # T_PACKEDARRAY |
322 | SCOPE: { | |
323 | note("T_PACKED_ARRAY"); | |
324 | my @d = ( | |
325 | -4, 3, 2.1, | |
326 | 2, 1, -15.3, | |
327 | 1,1,1 | |
328 | ); | |
329 | my @out; | |
330 | push @out, {a => $d[$_*3], b => $d[$_*3+1], c => $d[$_*3+2]} for (0..2); | |
331 | my $structs = T_PACKEDARRAY_out(@d); | |
332 | ok(ref($structs) eq 'ARRAY'); | |
864fd8d3 S |
333 | is(scalar(@$structs), 3); |
334 | foreach my $i (0..2) { | |
335 | my $s = $structs->[$i]; | |
336 | is(ref($s), 'HASH'); | |
337 | is_approx($s->{a}, $d[$i*3+0]); | |
338 | is_approx($s->{b}, $d[$i*3+1]); | |
339 | is_approx($s->{c}, $d[$i*3+2]); | |
340 | } | |
ea0d3d8e | 341 | my @rv = T_PACKEDARRAY_in($structs); |
864fd8d3 S |
342 | is(scalar(@rv), scalar(@d)); |
343 | foreach my $i (0..$#d) { | |
344 | is_approx($rv[$i], $d[$i]); | |
345 | } | |
ea0d3d8e | 346 | } |
ea035a69 JH |
347 | |
348 | # Skip T_DATAUNIT | |
349 | ||
350 | # Skip T_CALLBACK | |
351 | ||
352 | # T_ARRAY | |
ea035a69 JH |
353 | my @inarr = (1,2,3,4,5,6,7,8,9,10); |
354 | my @outarr = T_ARRAY( 5, @inarr ); | |
dcea22eb | 355 | is_deeply(\@outarr, \@inarr, "T_ARRAY"); |
ea035a69 JH |
356 | |
357 | # T_STDIO | |
dcea22eb | 358 | note("T_STDIO"); |
ea035a69 JH |
359 | |
360 | # open a file in XS for write | |
361 | my $testfile= "stdio.tmp"; | |
362 | my $fh = T_STDIO_open( $testfile ); | |
363 | ok( $fh ); | |
364 | ||
365 | # write to it using perl | |
366 | if (defined $fh) { | |
367 | ||
368 | my @lines = ("NormalSTDIO\n", "PerlIO\n"); | |
369 | ||
370 | # print to it using FILE* through XS | |
8618896a | 371 | is( T_STDIO_print($fh, $lines[0]), length($lines[0])); |
ea035a69 JH |
372 | |
373 | # print to it using normal perl | |
374 | ok(print $fh "$lines[1]"); | |
375 | ||
b9735fbe JH |
376 | # close it using XS if using perlio, using Perl otherwise |
377 | ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) ); | |
ea035a69 JH |
378 | |
379 | # open from perl, and check contents | |
380 | open($fh, "< $testfile"); | |
381 | ok($fh); | |
382 | my $line = <$fh>; | |
8618896a | 383 | is($line,$lines[0]); |
ea035a69 | 384 | $line = <$fh>; |
8618896a | 385 | is($line,$lines[1]); |
ea035a69 JH |
386 | |
387 | ok(close($fh)); | |
388 | ok(unlink($testfile)); | |
389 | ||
390 | } else { | |
391 | for (1..8) { | |
392 | skip("Skip Test not relevant since file was not opened correctly",0); | |
393 | } | |
394 | } | |
395 | ||
0a442273 | 396 | # T_INOUT |
60a929b5 CB |
397 | note("T_INOUT"); |
398 | SCOPE: { | |
399 | my $buf = ''; | |
400 | local $| = 1; | |
401 | open my $fh, "+<", \$buf or die $!; | |
402 | my $str = "Fooo!\n"; | |
403 | print $fh $str; | |
404 | my $fh2 = T_INOUT($fh); | |
405 | seek($fh2, 0, 0); | |
406 | is(readline($fh2), $str); | |
407 | ok(print $fh2 "foo\n"); | |
408 | } | |
21b5216d S |
409 | |
410 | # T_IN | |
60a929b5 CB |
411 | note("T_IN"); |
412 | SCOPE: { | |
413 | my $buf = "Hello!\n"; | |
414 | local $| = 1; | |
415 | open my $fh, "<", \$buf or die $!; | |
416 | my $fh2 = T_IN($fh); | |
417 | is(readline($fh2), $buf); | |
418 | local $SIG{__WARN__} = sub {die}; | |
419 | ok(not(eval {print $fh2 "foo\n"; 1})); | |
420 | } | |
21b5216d S |
421 | |
422 | # T_OUT | |
60a929b5 CB |
423 | note("T_OUT"); |
424 | SCOPE: { | |
425 | my $buf = ''; | |
426 | local $| = 1; | |
427 | open my $fh, "+<", \$buf or die $!; | |
428 | my $str = "Fooo!\n"; | |
429 | print $fh $str; | |
430 | my $fh2 = T_OUT($fh); | |
431 | seek($fh2, 0, 0); | |
432 | is(readline($fh2), $str); | |
433 | ok(eval {print $fh2 "foo\n"; 1}); | |
434 | } | |
864fd8d3 S |
435 | |
436 | sub is_approx { | |
437 | my ($l, $r, $n) = @_; | |
438 | if (not defined $l or not defined $r) { | |
439 | fail(defined($n) ? $n : ()); | |
440 | } | |
441 | else { | |
442 | ok($l < $r+1e-6 && $r < $l+1e-6, defined($n) ? $n : ()) | |
443 | or note("$l and $r seem to be different given a fuzz of 1e-6"); | |
444 | } | |
445 | } |