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