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