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 => 148;
  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 parent '-norequire', qw/ intObjPtr /;
  21   sub xxx { 1; }
  22 }
  23
  24 BEGIN {
  25   package intRefIvPtr::SubClass;
  26   use parent '-norequire', qw/ intRefIvPtr /;
  27   sub xxx { 1 }
  28 }
  29
  30 # T_SV - standard perl scalar value
  31 note("T_SV");
  32 my $sv = "Testing T_SV";
  33 is( T_SV($sv), $sv);
  34
  35 # T_SVREF - reference to Scalar
  36 note("T_SVREF");
  37 $sv .= "REF";
  38 my $svref = \$sv;
  39 is( T_SVREF($svref), $svref );
  40 is( ${ T_SVREF($svref) }, $$svref );
  41
  42 # Now test that a non reference is rejected
  43 # the typemaps croak
  44 eval { T_SVREF( "fail - not ref" ) };
  45 ok( $@ );
  46
  47 note("T_SVREF_REFCOUNT_FIXED");
  48 is( T_SVREF_REFCOUNT_FIXED($svref), $svref );
  49 is( ${ T_SVREF_REFCOUNT_FIXED($svref) }, $$svref );
  50 eval { T_SVREF_REFCOUNT_FIXED( "fail - not ref" ) };
  51 ok( $@ );
  52
  53
  54 # T_AVREF - reference to a perl Array
  55 note("T_AVREF");
  56 my @array;
  57 is( T_AVREF(\@array), \@array);
  58 # Now test that a non array ref is rejected
  59 eval { T_AVREF( \$sv ) };
  60 ok( $@ );
  61
  62 # T_AVREF_REFCOUNT_FIXED  - reference to a perl Array, refcount fixed
  63 note("T_AVREF_REFCOUNT_FIXED");
  64 is( T_AVREF_REFCOUNT_FIXED(\@array), \@array);
  65 # Now test that a non array ref is rejected
  66 eval { T_AVREF_REFCOUNT_FIXED( \$sv ) };
  67 ok( $@ );
  68
  69
  70 # T_HVREF - reference to a perl Hash
  71 note("T_HVREF");
  72 my %hash;
  73 is( T_HVREF(\%hash), \%hash);
  74 # Now test that a non hash ref is rejected
  75 eval { T_HVREF( \@array ) };
  76 ok( $@ );
  77
  78
  79 # T_HVREF_REFCOUNT_FIXED - reference to a perl Hash, refcount fixed
  80 note("T_HVREF_REFCOUNT_FIXED");
  81 is( T_HVREF_REFCOUNT_FIXED(\%hash), \%hash);
  82 # Now test that a non hash ref is rejected
  83 eval { T_HVREF_REFCOUNT_FIXED( \@array ) };
  84 ok( $@ );
  85
  86
  87 # T_CVREF - reference to perl subroutine
  88 note("T_CVREF");
  89 my $sub = sub { 1 };
  90 is( T_CVREF($sub), $sub );
  91 # Now test that a non code ref is rejected
  92 eval { T_CVREF( \@array ) };
  93 ok( $@ );
  94
  95 is( T_CVREF_REFCOUNT_FIXED($sub), $sub );
  96 # Now test that a non code ref is rejected
  97 eval { T_CVREF_REFCOUNT_FIXED( \@array ) };
  98 ok( $@ );
  99
 100
 101 # T_SYSRET - system return values
 102 note("T_SYSRET");
 103 # first check success
 104 ok( T_SYSRET_pass );
 105 # ... now failure
 106 is( T_SYSRET_fail, undef);
 107
 108 # T_UV - unsigned integer
 109 note("T_UV");
 110 is( T_UV(5), 5 );    # pass
 111 isnt( T_UV(-4), -4); # fail
 112
 113 # T_U_INT - unsigned integer with (unsigned int) cast
 114 note("T_U_INT");
 115 is( T_U_INT(5), 5 );    # pass
 116 isnt( T_U_INT(-4), -4); # fail
 117
 118 # T_IV - signed integer
 119 # T_INT - signed integer with cast
 120 # T_LONG - signed integer with cast to IV
 121 # T_SHORT - signed short
 122 for my $t (['T_IV', \&T_IV],
 123            ['T_INT', \&T_INT],
 124            ['T_LONG', \&T_LONG],
 125            ['T_SHORT', \&T_SHORT])
 126 {
 127   note($t->[0]);
 128   is( $t->[1]->(5), 5);
 129   is( $t->[1]->(-4), -4);
 130   is( $t->[1]->(4.1), int(4.1));
 131   is( $t->[1]->("52"), "52");
 132   isnt( $t->[1]->(4.5), 4.5); # failure
 133 }
 134
 135 if ($Config{shortsize} == 2) {
 136   isnt( T_SHORT(32801), 32801 );
 137 }
 138 else {
 139   pass(); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
 140 }
 141
 142 # T_ENUM - enum list
 143 ok( T_ENUM(), 'T_ENUM' ); # just hope for a true value
 144
 145 # T_BOOL - boolean
 146 note("T_BOOL");
 147
 148 ok( T_BOOL(52) );
 149 ok( ! T_BOOL(0) );
 150 ok( ! T_BOOL('') );
 151 ok( ! T_BOOL(undef) );
 152
 153 {
 154   # these attempt to modify a read-only value
 155   ok( !eval { T_BOOL_2(52); 1 } );
 156   ok( !eval { T_BOOL_2(0); 1 } );
 157   ok( !eval { T_BOOL_2(''); 1 } );
 158   ok( !eval { T_BOOL_2(undef); 1 } );
 159 }
 160
 161 {
 162     my ($in, $out);
 163     $in = 1;
 164     T_BOOL_OUT($out, $in);
 165     ok($out, "T_BOOL_OUT, true in");
 166     $in = 0;
 167     $out = 1;
 168     T_BOOL_OUT($out, $in);
 169     ok(!$out, "T_BOOL_OUT, false in");
 170 }
 171
 172 # T_U_SHORT aka U16
 173 note("T_U_SHORT");
 174 is( T_U_SHORT(32000), 32000);
 175 if ($Config{shortsize} == 2) {
 176   isnt( T_U_SHORT(65536), 65536); # probably dont want to test edge cases
 177 } else {
 178   ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
 179 }
 180
 181 # T_U_LONG aka U32
 182 note("T_U_LONG");
 183 is( T_U_LONG(65536), 65536);
 184 isnt( T_U_LONG(-1), -1);
 185
 186 # T_CHAR
 187 note("T_CHAR");
 188 is( T_CHAR("a"), "a");
 189 is( T_CHAR("-"), "-");
 190 is( T_CHAR(chr(128)),chr(128));
 191 isnt( T_CHAR(chr(256)), chr(256));
 192
 193 # T_U_CHAR
 194 note("T_U_CHAR");
 195 is( T_U_CHAR(127), 127);
 196 is( T_U_CHAR(128), 128);
 197 isnt( T_U_CHAR(-1), -1);
 198 isnt( T_U_CHAR(300), 300);
 199
 200 # T_FLOAT
 201 # limited precision
 202 is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345), "T_FLOAT");
 203
 204 # T_NV
 205 is( T_NV(52.345), 52.345, "T_NV" );
 206
 207 # T_DOUBLE
 208 is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345), "T_DOUBLE" );
 209
 210 # T_PV
 211 note("T_PV");
 212 is( T_PV("a string"), "a string");
 213 is( T_PV(52), 52);
 214 ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*';
 215 {
 216     my $uninit;
 217     local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ };
 218     () = ''.T_PV_null;
 219     is $uninit, 1, 'uninit warning from NULL returned from char* func';
 220 }
 221
 222 # T_PTR
 223 my $t = 5;
 224 my $ptr = T_PTR_OUT($t);
 225 is( T_PTR_IN( $ptr ), $t, "T_PTR" );
 226
 227 # T_PTRREF
 228 note("T_PTRREF");
 229 $t = -52;
 230 $ptr = T_PTRREF_OUT( $t );
 231 is( ref($ptr), "SCALAR");
 232 is( T_PTRREF_IN( $ptr ), $t );
 233
 234 # test that a non-scalar ref is rejected
 235 eval { T_PTRREF_IN( $t ); };
 236 ok( $@ );
 237
 238 # T_PTROBJ
 239 note("T_PTROBJ");
 240 $t = 256;
 241 $ptr = T_PTROBJ_OUT( $t );
 242 is( ref($ptr), "intObjPtr");
 243 is( $ptr->T_PTROBJ_IN, $t );
 244
 245 # check that normal scalar refs fail
 246 eval {intObjPtr::T_PTROBJ_IN( \$t );};
 247 ok( $@ );
 248
 249 # check that inheritance works
 250 bless $ptr, "intObjPtr::SubClass";
 251 is( ref($ptr), "intObjPtr::SubClass");
 252 is( $ptr->T_PTROBJ_IN, $t );
 253
 254 # Skip T_REF_IV_REF
 255
 256 # T_REF_IV_PTR
 257 note("T_REF_IV_PTR");
 258 $t = -365;
 259 $ptr = T_REF_IV_PTR_OUT( $t );
 260 is( ref($ptr), "intRefIvPtr");
 261 is( $ptr->T_REF_IV_PTR_IN(), $t);
 262
 263 # inheritance should not work
 264 bless $ptr, "intRefIvPtr::SubClass";
 265 eval { $ptr->T_REF_IV_PTR_IN };
 266 ok( $@ );
 267
 268 # Skip T_PTRDESC
 269
 270 # Skip T_REFREF
 271
 272 # Skip T_REFOBJ
 273
 274 # T_OPAQUEPTR
 275 note("T_OPAQUEPTR");
 276 $t = 22;
 277 my $p = T_OPAQUEPTR_IN( $t );
 278 is( T_OPAQUEPTR_OUT($p), $t);
 279
 280 # T_OPAQUEPTR with a struct
 281 note("T_OPAQUEPTR with a struct");
 282 my @test = (5,6,7);
 283 $p = T_OPAQUEPTR_IN_struct(@test);
 284 my @result = T_OPAQUEPTR_OUT_struct($p);
 285 is(scalar(@result),scalar(@test));
 286 for (0..$#test) {
 287   is($result[$_], $test[$_]);
 288 }
 289
 290 # T_OPAQUE
 291 note("T_OPAQUE");
 292 $t = 48;
 293 $p = T_OPAQUE_IN( $t );
 294 is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR
 295 is(T_OPAQUE_OUT( $p ), $t );         # Test using T_OPQAQUE
 296
 297 # T_OPAQUE_array
 298 note("T_OPAQUE: A packed array");
 299
 300 my @opq = (2,4,8);
 301 my $packed = T_OPAQUE_array(@opq);
 302 my @uopq = unpack("i*",$packed);
 303 is(scalar(@uopq), scalar(@opq));
 304 for (0..$#opq) {
 305   is( $uopq[$_], $opq[$_]);
 306 }
 307
 308 # T_PACKED
 309 note("T_PACKED");
 310 my $struct = T_PACKED_out(-4, 3, 2.1);
 311 ok(ref($struct) eq 'HASH');
 312 is_approx($struct->{a}, -4);
 313 is_approx($struct->{b}, 3);
 314 is_approx($struct->{c}, 2.1);
 315 my @rv = T_PACKED_in($struct);
 316 is(scalar(@rv), 3);
 317 is_approx($rv[0], -4);
 318 is_approx($rv[1], 3);
 319 is_approx($rv[2], 2.1);
 320
 321 # T_PACKEDARRAY
 322 SCOPE: {
 323   note("T_PACKED_ARRAY");
 324   my @d = (
 325     -4, 3, 2.1,
 326     2, 1, -15.3,
 327     1,1,1
 328   );
 329   my @out;
 330   push @out, {a => $d[$_*3], b => $d[$_*3+1], c => $d[$_*3+2]} for (0..2);
 331   my $structs = T_PACKEDARRAY_out(@d);
 332   ok(ref($structs) eq 'ARRAY');
 333   is(scalar(@$structs), 3);
 334   foreach my $i (0..2) {
 335     my $s = $structs->[$i];
 336     is(ref($s), 'HASH');
 337     is_approx($s->{a}, $d[$i*3+0]);
 338     is_approx($s->{b}, $d[$i*3+1]);
 339     is_approx($s->{c}, $d[$i*3+2]);
 340   }
 341   my @rv = T_PACKEDARRAY_in($structs);
 342   is(scalar(@rv), scalar(@d));
 343   foreach my $i (0..$#d) {
 344     is_approx($rv[$i], $d[$i]);
 345   }
 346 }
 347
 348 # Skip T_DATAUNIT
 349
 350 # Skip T_CALLBACK
 351
 352 # T_ARRAY
 353 my @inarr = (1,2,3,4,5,6,7,8,9,10);
 354 my @outarr = T_ARRAY( 5, @inarr );
 355 is_deeply(\@outarr, \@inarr, "T_ARRAY");
 356
 357 # T_STDIO
 358 note("T_STDIO");
 359
 360 # open a file in XS for write
 361 my $testfile= "stdio.tmp";
 362 my $fh = T_STDIO_open( $testfile );
 363 ok( $fh );
 364
 365 # write to it using perl
 366 if (defined $fh) {
 367
 368   my @lines = ("NormalSTDIO\n", "PerlIO\n");
 369
 370   # print to it using FILE* through XS
 371   is( T_STDIO_print($fh, $lines[0]), length($lines[0]));
 372
 373   # print to it using normal perl
 374   ok(print $fh "$lines[1]");
 375
 376   # close it using XS if using perlio, using Perl otherwise
 377   ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) );
 378
 379   # open from perl, and check contents
 380   open($fh, "< $testfile");
 381   ok($fh);
 382   my $line = <$fh>;
 383   is($line,$lines[0]);
 384   $line = <$fh>;
 385   is($line,$lines[1]);
 386
 387   ok(close($fh));
 388   ok(unlink($testfile));
 389
 390 } else {
 391   for (1..8) {
 392     skip("Skip Test not relevant since file was not opened correctly",0);
 393   }
 394 }
 395
 396 # T_INOUT
 397 note("T_INOUT");
 398 SCOPE: {
 399   my $buf = '';
 400   local $| = 1;
 401   open my $fh, "+<", \$buf or die $!;
 402   my $str = "Fooo!\n";
 403   print $fh $str;
 404   my $fh2 = T_INOUT($fh);
 405   seek($fh2, 0, 0);
 406   is(readline($fh2), $str);
 407   ok(print $fh2 "foo\n");
 408 }
 409
 410 # T_IN
 411 note("T_IN");
 412 SCOPE: {
 413   my $buf = "Hello!\n";
 414   local $| = 1;
 415   open my $fh, "<", \$buf or die $!;
 416   my $fh2 = T_IN($fh);
 417   is(readline($fh2), $buf);
 418   local $SIG{__WARN__} = sub {die};
 419   ok(not(eval {print $fh2 "foo\n"; 1}));
 420 }
 421
 422 # T_OUT
 423 note("T_OUT");
 424 SCOPE: {
 425   my $buf = '';
 426   local $| = 1;
 427   open my $fh, "+<", \$buf or die $!;
 428   my $str = "Fooo!\n";
 429   print $fh $str;
 430   my $fh2 = T_OUT($fh);
 431   seek($fh2, 0, 0);
 432   is(readline($fh2), $str);
 433   ok(eval {print $fh2 "foo\n"; 1});
 434 }
 435
 436 sub is_approx {
 437   my ($l, $r, $n) = @_;
 438   if (not defined $l or not defined $r) {
 439     fail(defined($n) ? $n : ());
 440   }
 441   else {
 442     ok($l < $r+1e-6 && $r < $l+1e-6, defined($n) ? $n : ())
 443       or note("$l and $r seem to be different given a fuzz of 1e-6");
 444   }
 445 }