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
1 BEGIN {
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     }
9 }
10
11 use Test;
12 BEGIN { plan tests => 84 }
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);
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 }
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
165 ok( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345));
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
175 ok( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345));
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;
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 }
257
258 # T_OPAQUE
259 print "# T_OPAQUE\n";
260
261 $t = 48;
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
265
266 # T_OPAQUE_array
267 print "# A packed  array\n";
268
269 my @opq = (2,4,8);
270 my $packed = T_OPAQUE_array(@opq);
271 my @uopq = unpack("i*",$packed);
272 ok(scalar(@uopq), scalar(@opq));
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
316   # close it using XS if using perlio, using Perl otherwise
317   ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) );
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