t/lib/xs-typemap.t

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