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