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); |
130 | ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases |
131 | |
132 | # T_U_LONG aka U32 |
133 | |
134 | print "# T_U_LONG\n"; |
135 | |
136 | ok( T_U_LONG(65536), 65536); |
137 | ok( T_U_LONG(-1) != -1); |
138 | |
139 | # T_CHAR |
140 | |
141 | print "# T_CHAR\n"; |
142 | |
143 | ok( T_CHAR("a"), "a"); |
144 | ok( T_CHAR("-"), "-"); |
145 | ok( T_CHAR(chr(128)),chr(128)); |
146 | ok( T_CHAR(chr(256)) ne chr(256)); |
147 | |
148 | # T_U_CHAR |
149 | |
150 | print "# T_U_CHAR\n"; |
151 | |
152 | ok( T_U_CHAR(127), 127); |
153 | ok( T_U_CHAR(128), 128); |
154 | ok( T_U_CHAR(-1) != -1); |
155 | ok( T_U_CHAR(300) != 300); |
156 | |
157 | # T_FLOAT |
158 | print "# T_FLOAT\n"; |
159 | |
160 | # limited precision |
161 | ok( sprintf("%6.3f",T_FLOAT(52.345)), 52.345); |
162 | |
163 | # T_NV |
164 | print "# T_NV\n"; |
165 | |
166 | ok( T_NV(52.345), 52.345); |
167 | |
168 | # T_DOUBLE |
169 | print "# T_DOUBLE\n"; |
170 | |
171 | ok( T_DOUBLE(52.345), 52.345); |
172 | |
173 | # T_PV |
174 | print "# T_PV\n"; |
175 | |
176 | ok( T_PV("a string"), "a string"); |
177 | ok( T_PV(52), 52); |
178 | |
179 | # T_PTR |
180 | print "# T_PTR\n"; |
181 | |
182 | my $t = 5; |
183 | my $ptr = T_PTR_OUT($t); |
184 | ok( T_PTR_IN( $ptr ), $t ); |
185 | |
186 | # T_PTRREF |
187 | print "# T_PTRREF\n"; |
188 | |
189 | $t = -52; |
190 | $ptr = T_PTRREF_OUT( $t ); |
191 | ok( ref($ptr), "SCALAR"); |
192 | ok( T_PTRREF_IN( $ptr ), $t ); |
193 | |
194 | # test that a non-scalar ref is rejected |
195 | eval { T_PTRREF_IN( $t ); }; |
196 | ok( $@ ); |
197 | |
198 | # T_PTROBJ |
199 | print "# T_PTROBJ\n"; |
200 | |
201 | $t = 256; |
202 | $ptr = T_PTROBJ_OUT( $t ); |
203 | ok( ref($ptr), "intObjPtr"); |
204 | ok( $ptr->T_PTROBJ_IN, $t ); |
205 | |
206 | # check that normal scalar refs fail |
207 | eval {intObjPtr::T_PTROBJ_IN( \$t );}; |
208 | ok( $@ ); |
209 | |
210 | # check that inheritance works |
211 | bless $ptr, "intObjPtr::SubClass"; |
212 | ok( ref($ptr), "intObjPtr::SubClass"); |
213 | ok( $ptr->T_PTROBJ_IN, $t ); |
214 | |
215 | # Skip T_REF_IV_REF |
216 | |
217 | # T_REF_IV_PTR |
218 | print "# T_REF_IV_PTR\n"; |
219 | |
220 | $t = -365; |
221 | $ptr = T_REF_IV_PTR_OUT( $t ); |
222 | ok( ref($ptr), "intRefIvPtr"); |
223 | ok( $ptr->T_REF_IV_PTR_IN(), $t); |
224 | |
225 | # inheritance should not work |
226 | bless $ptr, "intRefIvPtr::SubClass"; |
227 | eval { $ptr->T_REF_IV_PTR_IN }; |
228 | ok( $@ ); |
229 | |
230 | # Skip T_PTRDESC |
231 | |
232 | # Skip T_REFREF |
233 | |
234 | # Skip T_REFOBJ |
235 | |
236 | # T_OPAQUEPTR |
237 | print "# T_OPAQUEPTR\n"; |
238 | |
239 | $t = 22; |
240 | $ptr = T_OPAQUEPTR_IN( $t ); |
241 | ok( T_OPAQUEPTR_OUT($ptr), $t); |
242 | |
243 | # T_OPAQUE |
244 | print "# T_OPAQUE\n"; |
245 | |
246 | $t = 48; |
247 | $ptr = T_OPAQUE_IN( $t ); |
aa921f48 |
248 | ok(T_OPAQUEPTR_OUT_short( $ptr ), $t); |
ea035a69 |
249 | |
250 | # T_OPAQUE_array |
251 | my @opq = (2,4,8); |
252 | my $packed = T_OPAQUE_array(@opq); |
253 | my @uopq = unpack("i*",$packed); |
254 | for (0..$#opq) { |
255 | ok( $uopq[$_], $opq[$_]); |
256 | } |
257 | |
258 | # Skip T_PACKED |
259 | |
260 | # Skip T_PACKEDARRAY |
261 | |
262 | # Skip T_DATAUNIT |
263 | |
264 | # Skip T_CALLBACK |
265 | |
266 | # T_ARRAY |
267 | print "# T_ARRAY\n"; |
268 | my @inarr = (1,2,3,4,5,6,7,8,9,10); |
269 | my @outarr = T_ARRAY( 5, @inarr ); |
270 | ok(scalar(@outarr), scalar(@inarr)); |
271 | |
272 | for (0..$#inarr) { |
273 | ok($outarr[$_], $inarr[$_]); |
274 | } |
275 | |
276 | |
277 | |
278 | # T_STDIO |
279 | print "# T_STDIO\n"; |
280 | |
281 | # open a file in XS for write |
282 | my $testfile= "stdio.tmp"; |
283 | my $fh = T_STDIO_open( $testfile ); |
284 | ok( $fh ); |
285 | |
286 | # write to it using perl |
287 | if (defined $fh) { |
288 | |
289 | my @lines = ("NormalSTDIO\n", "PerlIO\n"); |
290 | |
291 | # print to it using FILE* through XS |
292 | ok( T_STDIO_print($fh, $lines[0]), length($lines[0])); |
293 | |
294 | # print to it using normal perl |
295 | ok(print $fh "$lines[1]"); |
296 | |
297 | # close it using XS |
298 | # This works fine but causes a segmentation fault during global |
299 | # destruction when the glob associated with this filehandle is |
300 | # tidied up. |
301 | # ok( T_STDIO_close( $fh ) ); |
302 | ok(close($fh)); # using perlio to close the glob works fine |
303 | |
304 | # open from perl, and check contents |
305 | open($fh, "< $testfile"); |
306 | ok($fh); |
307 | my $line = <$fh>; |
308 | ok($line,$lines[0]); |
309 | $line = <$fh>; |
310 | ok($line,$lines[1]); |
311 | |
312 | ok(close($fh)); |
313 | ok(unlink($testfile)); |
314 | |
315 | } else { |
316 | for (1..8) { |
317 | skip("Skip Test not relevant since file was not opened correctly",0); |
318 | } |
319 | } |
320 | |