ext/XS-Typemap/t/Typemap.t

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