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