7 BEGIN { plan tests => 78 }
15 # Some inheritance trees to check ISA relationships
17 package intObjPtr::SubClass;
18 use base qw/ intObjPtr /;
23 package intRefIvPtr::SubClass;
24 use base qw/ intRefIvPtr /;
28 # T_SV - standard perl scalar value
31 my $sv = "Testing T_SV";
34 # T_SVREF - reference to Scalar
39 ok( T_SVREF($svref), $svref );
41 # Now test that a non reference is rejected
43 eval { T_SVREF( "fail - not ref" ) };
46 # T_AVREF - reference to a perl Array
50 ok( T_AVREF(\@array), \@array);
52 # Now test that a non array ref is rejected
53 eval { T_AVREF( \$sv ) };
56 # T_HVREF - reference to a perl Hash
60 ok( T_HVREF(\%hash), \%hash);
62 # Now test that a non hash ref is rejected
63 eval { T_HVREF( \@array ) };
67 # T_CVREF - reference to perl subroutine
70 ok( T_CVREF($sub), $sub );
72 # Now test that a non code ref is rejected
73 eval { T_CVREF( \@array ) };
76 # T_SYSRET - system return values
83 ok( T_SYSRET_fail, undef);
85 # T_UV - unsigned integer
88 ok( T_UV(5), 5 ); # pass
89 ok( T_UV(-4) != -4); # fail
91 # T_IV - signed integer
96 ok( T_IV(4.1), int(4.1));
97 ok( T_IV("52"), "52");
98 ok( T_IV(4.5) != 4.5); # failure
106 ok( T_ENUM() ); # just hope for a true value
114 ok( ! T_BOOL(undef) );
122 print "# T_U_SHORT\n";
124 ok( T_U_SHORT(32000), 32000);
125 ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases
129 print "# T_U_LONG\n";
131 ok( T_U_LONG(65536), 65536);
132 ok( T_U_LONG(-1) != -1);
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));
145 print "# T_U_CHAR\n";
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);
156 ok( sprintf("%6.3f",T_FLOAT(52.345)), 52.345);
161 ok( T_NV(52.345), 52.345);
164 print "# T_DOUBLE\n";
166 ok( T_DOUBLE(52.345), 52.345);
171 ok( T_PV("a string"), "a string");
178 my $ptr = T_PTR_OUT($t);
179 ok( T_PTR_IN( $ptr ), $t );
182 print "# T_PTRREF\n";
185 $ptr = T_PTRREF_OUT( $t );
186 ok( ref($ptr), "SCALAR");
187 ok( T_PTRREF_IN( $ptr ), $t );
189 # test that a non-scalar ref is rejected
190 eval { T_PTRREF_IN( $t ); };
194 print "# T_PTROBJ\n";
197 $ptr = T_PTROBJ_OUT( $t );
198 ok( ref($ptr), "intObjPtr");
199 ok( $ptr->T_PTROBJ_IN, $t );
201 # check that normal scalar refs fail
202 eval {intObjPtr::T_PTROBJ_IN( \$t );};
205 # check that inheritance works
206 bless $ptr, "intObjPtr::SubClass";
207 ok( ref($ptr), "intObjPtr::SubClass");
208 ok( $ptr->T_PTROBJ_IN, $t );
213 print "# T_REF_IV_PTR\n";
216 $ptr = T_REF_IV_PTR_OUT( $t );
217 ok( ref($ptr), "intRefIvPtr");
218 ok( $ptr->T_REF_IV_PTR_IN(), $t);
220 # inheritance should not work
221 bless $ptr, "intRefIvPtr::SubClass";
222 eval { $ptr->T_REF_IV_PTR_IN };
232 print "# T_OPAQUEPTR\n";
235 $ptr = T_OPAQUEPTR_IN( $t );
236 ok( T_OPAQUEPTR_OUT($ptr), $t);
239 print "# T_OPAQUE\n";
242 $ptr = T_OPAQUE_IN( $t );
243 ok(T_OPAQUEPTR_OUT( $ptr ), $t);
247 my $packed = T_OPAQUE_array(@opq);
248 my @uopq = unpack("i*",$packed);
250 ok( $uopq[$_], $opq[$_]);
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));
268 ok($outarr[$_], $inarr[$_]);
276 # open a file in XS for write
277 my $testfile= "stdio.tmp";
278 my $fh = T_STDIO_open( $testfile );
281 # write to it using perl
284 my @lines = ("NormalSTDIO\n", "PerlIO\n");
286 # print to it using FILE* through XS
287 ok( T_STDIO_print($fh, $lines[0]), length($lines[0]));
289 # print to it using normal perl
290 ok(print $fh "$lines[1]");
293 # This works fine but causes a segmentation fault during global
294 # destruction when the glob associated with this filehandle is
296 # ok( T_STDIO_close( $fh ) );
297 ok(close($fh)); # using perlio to close the glob works fine
299 # open from perl, and check contents
300 open($fh, "< $testfile");
308 ok(unlink($testfile));
312 skip("Skip Test not relevant since file was not opened correctly",0);