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