This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
27b40860fdf2ea89c167003914f984f8465fab85
[perl5.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 => 152;
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 parent '-norequire', qw/ intObjPtr /;
21   sub xxx { 1; }
22 }
23
24 BEGIN {
25   package intRefIvPtr::SubClass;
26   use parent '-norequire', 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 {
154   # these attempt to modify a read-only value
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 }
160
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;
167     $out = 1;
168     T_BOOL_OUT($out, $in);
169     ok(!$out, "T_BOOL_OUT, false in");
170 }
171
172 # T_U_SHORT aka U16
173 note("T_U_SHORT");
174 is( T_U_SHORT(32000), 32000);
175 if ($Config{shortsize} == 2) {
176   isnt( T_U_SHORT(65536), 65536); # probably dont want to test edge cases
177 } else {
178   ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
179 }
180
181 # T_U_LONG aka U32
182 note("T_U_LONG");
183 is( T_U_LONG(65536), 65536);
184 isnt( T_U_LONG(-1), -1);
185
186 # T_CHAR
187 note("T_CHAR");
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));
192
193 # T_U_CHAR
194 note("T_U_CHAR");
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);
199
200 # T_FLOAT
201 # limited precision
202 is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345), "T_FLOAT");
203
204 # T_NV
205 is( T_NV(52.345), 52.345, "T_NV" );
206
207 # T_DOUBLE
208 is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345), "T_DOUBLE" );
209
210 # T_PV
211 note("T_PV");
212 is( T_PV("a string"), "a string");
213 is( T_PV(52), 52);
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 }
221
222 # T_PTR
223 my $t = 5;
224 my $ptr = T_PTR_OUT($t);
225 is( T_PTR_IN( $ptr ), $t, "T_PTR" );
226
227 # T_PTRREF
228 note("T_PTRREF");
229 $t = -52;
230 $ptr = T_PTRREF_OUT( $t );
231 is( ref($ptr), "SCALAR");
232 is( T_PTRREF_IN( $ptr ), $t );
233
234 # test that a non-scalar ref is rejected
235 eval { T_PTRREF_IN( $t ); };
236 ok( $@ );
237
238 # T_PTROBJ
239 note("T_PTROBJ");
240 $t = 256;
241 $ptr = T_PTROBJ_OUT( $t );
242 is( ref($ptr), "intObjPtr");
243 is( $ptr->T_PTROBJ_IN, $t );
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";
251 is( ref($ptr), "intObjPtr::SubClass");
252 is( $ptr->T_PTROBJ_IN, $t );
253
254 # Skip T_REF_IV_REF
255
256 # T_REF_IV_PTR
257 note("T_REF_IV_PTR");
258 $t = -365;
259 $ptr = T_REF_IV_PTR_OUT( $t );
260 is( ref($ptr), "intRefIvPtr");
261 is( $ptr->T_REF_IV_PTR_IN(), $t);
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
275 note("T_OPAQUEPTR");
276 $t = 22;
277 my $p = T_OPAQUEPTR_IN( $t );
278 is( T_OPAQUEPTR_OUT($p), $t);
279
280 # T_OPAQUEPTR with a struct
281 note("T_OPAQUEPTR with a struct");
282 my @test = (5,6,7);
283 $p = T_OPAQUEPTR_IN_struct(@test);
284 my @result = T_OPAQUEPTR_OUT_struct($p);
285 is(scalar(@result),scalar(@test));
286 for (0..$#test) {
287   is($result[$_], $test[$_]);
288 }
289
290 # T_OPAQUE
291 note("T_OPAQUE");
292 $t = 48;
293 $p = T_OPAQUE_IN( $t );
294 is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR
295 is(T_OPAQUE_OUT( $p ), $t );         # Test using T_OPQAQUE
296
297 # T_OPAQUE_array
298 note("T_OPAQUE: A packed array");
299
300 my @opq = (2,4,8);
301 my $packed = T_OPAQUE_array(@opq);
302 my @uopq = unpack("i*",$packed);
303 is(scalar(@uopq), scalar(@opq));
304 for (0..$#opq) {
305   is( $uopq[$_], $opq[$_]);
306 }
307
308 # T_PACKED
309 note("T_PACKED");
310 my $struct = T_PACKED_out(-4, 3, 2.1);
311 ok(ref($struct) eq 'HASH');
312 is_approx($struct->{a}, -4);
313 is_approx($struct->{b}, 3);
314 is_approx($struct->{c}, 2.1);
315 my @rv = T_PACKED_in($struct);
316 is(scalar(@rv), 3);
317 is_approx($rv[0], -4);
318 is_approx($rv[1], 3);
319 is_approx($rv[2], 2.1);
320
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');
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   }
341   my @rv = T_PACKEDARRAY_in($structs);
342   is(scalar(@rv), scalar(@d));
343   foreach my $i (0..$#d) {
344     is_approx($rv[$i], $d[$i]);
345   }
346 }
347
348 # Skip T_DATAUNIT
349
350 # Skip T_CALLBACK
351
352 # T_ARRAY
353 my @inarr = (1,2,3,4,5,6,7,8,9,10);
354 my @outarr = T_ARRAY( 5, @inarr );
355 is_deeply(\@outarr, \@inarr, "T_ARRAY");
356
357 # T_STDIO
358 note("T_STDIO");
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
371   is( T_STDIO_print($fh, $lines[0]), length($lines[0]));
372
373   # print to it using normal perl
374   ok(print $fh "$lines[1]");
375
376   # close it using XS if using perlio, using Perl otherwise
377   ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) );
378
379   # open from perl, and check contents
380   open($fh, "< $testfile");
381   ok($fh);
382   my $line = <$fh>;
383   is($line,$lines[0]);
384   $line = <$fh>;
385   is($line,$lines[1]);
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
396 # T_INOUT
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   ok(close $fh);
409   # this fails because the underlying shared handle is already closed
410   ok(!close $fh2);
411 }
412
413 # T_IN
414 note("T_IN");
415 SCOPE: {
416   my $buf = "Hello!\n";
417   local $| = 1;
418   open my $fh, "<", \$buf or die $!;
419   my $fh2 = T_IN($fh);
420   is(readline($fh2), $buf);
421   local $SIG{__WARN__} = sub {die};
422   ok(not(eval {print $fh2 "foo\n"; 1}));
423 }
424
425 # T_OUT
426 note("T_OUT");
427 SCOPE: {
428   my $buf = '';
429   local $| = 1;
430   open my $fh, "+<", \$buf or die $!;
431   my $str = "Fooo!\n";
432   print $fh $str;
433   my $fh2 = T_OUT($fh);
434   seek($fh2, 0, 0);
435   is(readline($fh2), $str);
436   ok(eval {print $fh2 "foo\n"; 1});
437   ok(close $fh);
438   # this fails because the underlying shared handle is already closed
439   ok(!close $fh2);
440 }
441
442 sub is_approx {
443   my ($l, $r, $n) = @_;
444   if (not defined $l or not defined $r) {
445     fail(defined($n) ? $n : ());
446   }
447   else {
448     ok($l < $r+1e-6 && $r < $l+1e-6, defined($n) ? $n : ())
449       or note("$l and $r seem to be different given a fuzz of 1e-6");
450   }
451 }