Commit | Line | Data |
cf12903c |
1 | BEGIN { |
16421035 |
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 |
9 | } |
10 | |
ea035a69 |
11 | use Test; |
12 | BEGIN { plan tests => 78 } |
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); |
95e35ab6 |
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 | } |
ea035a69 |
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)), 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( T_DOUBLE(52.345), 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 | $ptr = T_OPAQUEPTR_IN( $t ); |
245 | ok( T_OPAQUEPTR_OUT($ptr), $t); |
246 | |
247 | # T_OPAQUE |
248 | print "# T_OPAQUE\n"; |
249 | |
250 | $t = 48; |
251 | $ptr = T_OPAQUE_IN( $t ); |
aa921f48 |
252 | ok(T_OPAQUEPTR_OUT_short( $ptr ), $t); |
ea035a69 |
253 | |
254 | # T_OPAQUE_array |
255 | my @opq = (2,4,8); |
256 | my $packed = T_OPAQUE_array(@opq); |
257 | my @uopq = unpack("i*",$packed); |
258 | for (0..$#opq) { |
259 | ok( $uopq[$_], $opq[$_]); |
260 | } |
261 | |
262 | # Skip T_PACKED |
263 | |
264 | # Skip T_PACKEDARRAY |
265 | |
266 | # Skip T_DATAUNIT |
267 | |
268 | # Skip T_CALLBACK |
269 | |
270 | # T_ARRAY |
271 | print "# T_ARRAY\n"; |
272 | my @inarr = (1,2,3,4,5,6,7,8,9,10); |
273 | my @outarr = T_ARRAY( 5, @inarr ); |
274 | ok(scalar(@outarr), scalar(@inarr)); |
275 | |
276 | for (0..$#inarr) { |
277 | ok($outarr[$_], $inarr[$_]); |
278 | } |
279 | |
280 | |
281 | |
282 | # T_STDIO |
283 | print "# T_STDIO\n"; |
284 | |
285 | # open a file in XS for write |
286 | my $testfile= "stdio.tmp"; |
287 | my $fh = T_STDIO_open( $testfile ); |
288 | ok( $fh ); |
289 | |
290 | # write to it using perl |
291 | if (defined $fh) { |
292 | |
293 | my @lines = ("NormalSTDIO\n", "PerlIO\n"); |
294 | |
295 | # print to it using FILE* through XS |
296 | ok( T_STDIO_print($fh, $lines[0]), length($lines[0])); |
297 | |
298 | # print to it using normal perl |
299 | ok(print $fh "$lines[1]"); |
300 | |
301 | # close it using XS |
302 | # This works fine but causes a segmentation fault during global |
303 | # destruction when the glob associated with this filehandle is |
304 | # tidied up. |
305 | # ok( T_STDIO_close( $fh ) ); |
306 | ok(close($fh)); # using perlio to close the glob works fine |
307 | |
308 | # open from perl, and check contents |
309 | open($fh, "< $testfile"); |
310 | ok($fh); |
311 | my $line = <$fh>; |
312 | ok($line,$lines[0]); |
313 | $line = <$fh>; |
314 | ok($line,$lines[1]); |
315 | |
316 | ok(close($fh)); |
317 | ok(unlink($testfile)); |
318 | |
319 | } else { |
320 | for (1..8) { |
321 | skip("Skip Test not relevant since file was not opened correctly",0); |
322 | } |
323 | } |
324 | |