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