1#!/usr/bin/perl 2 3use strict; 4use Test::More tests => 30; 5use Config; 6use DynaLoader; 7use ExtUtils::CBuilder; 8use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); 9use PrimitiveCapture; 10 11my ($source_file, $obj_file, $lib_file); 12 13require_ok( 'ExtUtils::ParseXS' ); 14 15chdir('t') if -d 't'; 16push @INC, '.'; 17 18$ExtUtils::ParseXS::DIE_ON_ERROR = 1; 19$ExtUtils::ParseXS::AUTHOR_WARNINGS = 1; 20 21use Carp; #$SIG{__WARN__} = \&Carp::cluck; 22 23# The linker on some platforms doesn't like loading libraries using relative 24# paths. Android won't find relative paths, and system perl on macOS will 25# refuse to load relative paths. The path that DynaLoader uses to load the 26# .so or .bundle file is based on the @INC path that the library is loaded 27# from. The XSTest module we're using for testing is in the current directory, 28# so we need an absolute path in @INC rather than '.'. Just convert all of the 29# paths to absolute for simplicity. 30@INC = map { File::Spec->rel2abs($_) } @INC; 31 32######################### 33 34{ # first block: try without linenumbers 35my $pxs = ExtUtils::ParseXS->new; 36# Try sending to filehandle 37tie *FH, 'Foo'; 38$pxs->process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 ); 39like tied(*FH)->content, '/is_even/', "Test that output contains some text"; 40 41$source_file = 'XSTest.c'; 42 43# Try sending to file 44$pxs->process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0); 45ok -e $source_file, "Create an output file"; 46 47my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; 48my $b = ExtUtils::CBuilder->new(quiet => $quiet); 49 50SKIP: { 51 skip "no compiler available", 2 52 if ! $b->have_compiler; 53 $obj_file = $b->compile( source => $source_file ); 54 ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; 55 ok -e $obj_file, "Make sure $obj_file exists"; 56} 57 58SKIP: { 59 skip "no dynamic loading", 5 60 if !$b->have_compiler || !$Config{usedl}; 61 my $module = 'XSTest'; 62 $lib_file = $b->link( objects => $obj_file, module_name => $module ); 63 ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; 64 ok -e $lib_file, "Make sure $lib_file exists"; 65 66 eval {require XSTest}; 67 is $@, '', "No error message recorded, as expected"; 68 ok XSTest::is_even(8), 69 "Function created thru XS returned expected true value"; 70 ok !XSTest::is_even(9), 71 "Function created thru XS returned expected false value"; 72 73 # Win32 needs to close the DLL before it can unlink it, but unfortunately 74 # dl_unload_file was missing on Win32 prior to perl change #24679! 75 if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { 76 for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { 77 if ($DynaLoader::dl_modules[$i] eq $module) { 78 DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); 79 last; 80 } 81 } 82 } 83} 84 85my $seen = 0; 86open my $IN, '<', $source_file 87 or die "Unable to open $source_file: $!"; 88while (my $l = <$IN>) { 89 $seen++ if $l =~ m/#line\s1\s/; 90} 91is( $seen, 1, "Line numbers created in output file, as intended" ); 92{ 93 #rewind .c file and regexp it to look for code generation problems 94 local $/ = undef; 95 seek($IN, 0, 0); 96 my $filecontents = <$IN>; 97 $filecontents =~ s/^#if defined\(__HP_cc\).*\n#.*\n#endif\n//gm; 98 my $good_T_BOOL_re = 99qr|\QXS_EUPXS(XS_XSTest_T_BOOL)\E 100.+? 101#line \d+\Q "XSTest.c" 102 ST(0) = boolSV(RETVAL); 103 } 104 XSRETURN(1); 105} 106\E|s; 107 like($filecontents, $good_T_BOOL_re, "T_BOOL doesn\'t have an extra sv_newmortal or sv_2mortal"); 108 109 my $good_T_BOOL_2_re = 110qr|\QXS_EUPXS(XS_XSTest_T_BOOL_2)\E 111.+? 112#line \d+\Q "XSTest.c" 113 sv_setsv(ST(0), boolSV(in)); 114 SvSETMAGIC(ST(0)); 115 } 116 XSRETURN(1); 117} 118\E|s; 119 like($filecontents, $good_T_BOOL_2_re, 'T_BOOL_2 doesn\'t have an extra sv_newmortal or sv_2mortal'); 120 my $good_T_BOOL_OUT_re = 121qr|\QXS_EUPXS(XS_XSTest_T_BOOL_OUT)\E 122.+? 123#line \d+\Q "XSTest.c" 124 sv_setsv(ST(0), boolSV(out)); 125 SvSETMAGIC(ST(0)); 126 } 127 XSRETURN_EMPTY; 128} 129\E|s; 130 like($filecontents, $good_T_BOOL_OUT_re, 'T_BOOL_OUT doesn\'t have an extra sv_newmortal or sv_2mortal'); 131 132} 133close $IN or die "Unable to close $source_file: $!"; 134 135unless ($ENV{PERL_NO_CLEANUP}) { 136 for ( $obj_file, $lib_file, $source_file) { 137 next unless defined $_; 138 1 while unlink $_; 139 } 140} 141} 142 143##################################################################### 144 145{ # second block: try with linenumbers 146my $pxs = ExtUtils::ParseXS->new; 147# Try sending to filehandle 148tie *FH, 'Foo'; 149$pxs->process_file( 150 filename => 'XSTest.xs', 151 output => \*FH, 152 prototypes => 1, 153 linenumbers => 0, 154); 155like tied(*FH)->content, '/is_even/', "Test that output contains some text"; 156 157$source_file = 'XSTest.c'; 158 159# Try sending to file 160$pxs->process_file( 161 filename => 'XSTest.xs', 162 output => $source_file, 163 prototypes => 0, 164 linenumbers => 0, 165); 166ok -e $source_file, "Create an output file"; 167 168 169my $seen = 0; 170open my $IN, '<', $source_file 171 or die "Unable to open $source_file: $!"; 172while (my $l = <$IN>) { 173 $seen++ if $l =~ m/#line\s1\s/; 174} 175close $IN or die "Unable to close $source_file: $!"; 176is( $seen, 0, "No linenumbers created in output file, as intended" ); 177 178unless ($ENV{PERL_NO_CLEANUP}) { 179 for ( $obj_file, $lib_file, $source_file) { 180 next unless defined $_; 181 1 while unlink $_; 182 } 183} 184} 185##################################################################### 186 187{ # third block: broken typemap 188my $pxs = ExtUtils::ParseXS->new; 189tie *FH, 'Foo'; 190my $stderr = PrimitiveCapture::capture_stderr(sub { 191 $pxs->process_file(filename => 'XSBroken.xs', output => \*FH); 192}); 193like $stderr, '/No INPUT definition/', "Exercise typemap error"; 194} 195##################################################################### 196 197{ # fourth block: https://github.com/Perl/perl5/issues/19661 198 my $pxs = ExtUtils::ParseXS->new; 199 tie *FH, 'Foo'; 200 my ($stderr, $filename); 201 { 202 $filename = 'XSFalsePositive.xs'; 203 $stderr = PrimitiveCapture::capture_stderr(sub { 204 $pxs->process_file(filename => $filename, output => \*FH, prototypes => 1); 205 }); 206 TODO: { 207 local $TODO = 'GH 19661'; 208 unlike $stderr, 209 qr/Warning: duplicate function definition 'do' detected in \Q$filename\E/, 210 "No 'duplicate function definition' warning observed in $filename"; 211 } 212 } 213 { 214 $filename = 'XSFalsePositive2.xs'; 215 $stderr = PrimitiveCapture::capture_stderr(sub { 216 $pxs->process_file(filename => $filename, output => \*FH, prototypes => 1); 217 }); 218 TODO: { 219 local $TODO = 'GH 19661'; 220 unlike $stderr, 221 qr/Warning: duplicate function definition 'do' detected in \Q$filename\E/, 222 "No 'duplicate function definition' warning observed in $filename"; 223 } 224 } 225} 226 227##################################################################### 228 229{ # tight cpp directives 230 my $pxs = ExtUtils::ParseXS->new; 231 tie *FH, 'Foo'; 232 my $stderr = PrimitiveCapture::capture_stderr(sub { eval { 233 $pxs->process_file( 234 filename => 'XSTightDirectives.xs', 235 output => \*FH, 236 prototypes => 1); 237 } or warn $@ }); 238 my $content = tied(*FH)->{buf}; 239 my $count = 0; 240 $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg; 241 is $stderr, undef, "No error expected from TightDirectives.xs"; 242 is $count, 2, "Saw XS_MY_do definition the expected number of times"; 243} 244 245{ # Alias check 246 my $pxs = ExtUtils::ParseXS->new; 247 tie *FH, 'Foo'; 248 my $stderr = PrimitiveCapture::capture_stderr(sub { 249 $pxs->process_file( 250 filename => 'XSAlias.xs', 251 output => \*FH, 252 prototypes => 1); 253 }); 254 my $content = tied(*FH)->{buf}; 255 my $count = 0; 256 $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg; 257 is $stderr, 258 "Warning: Aliases 'pox' and 'dox', 'lox' have" 259 . " identical values of 1 in XSAlias.xs, line 9\n" 260 . " (If this is deliberate use a symbolic alias instead.)\n" 261 . "Warning: Conflicting duplicate alias 'pox' changes" 262 . " definition from '1' to '2' in XSAlias.xs, line 10\n" 263 . "Warning: Aliases 'docks' and 'dox', 'lox' have" 264 . " identical values of 1 in XSAlias.xs, line 11\n" 265 . "Warning: Aliases 'xunx' and 'do' have identical values" 266 . " of 0 - the base function in XSAlias.xs, line 13\n", 267 "Saw expected warnings from XSAlias.xs in AUTHOR_WARNINGS mode"; 268 269 my $expect = quotemeta(<<'EOF_CONTENT'); 270 cv = newXSproto_portable("My::dachs", XS_My_do, file, "$"); 271 XSANY.any_i32 = 1; 272 cv = newXSproto_portable("My::do", XS_My_do, file, "$"); 273 XSANY.any_i32 = 0; 274 cv = newXSproto_portable("My::docks", XS_My_do, file, "$"); 275 XSANY.any_i32 = 1; 276 cv = newXSproto_portable("My::dox", XS_My_do, file, "$"); 277 XSANY.any_i32 = 1; 278 cv = newXSproto_portable("My::lox", XS_My_do, file, "$"); 279 XSANY.any_i32 = 1; 280 cv = newXSproto_portable("My::pox", XS_My_do, file, "$"); 281 XSANY.any_i32 = 2; 282 cv = newXSproto_portable("My::xukes", XS_My_do, file, "$"); 283 XSANY.any_i32 = 0; 284 cv = newXSproto_portable("My::xunx", XS_My_do, file, "$"); 285 XSANY.any_i32 = 0; 286EOF_CONTENT 287 $expect=~s/(?:\\[ ])+/\\s+/g; 288 $expect=qr/$expect/; 289 like $content, $expect, "Saw expected alias initialization"; 290 291 #diag $content; 292} 293{ # Alias check with no dev warnings. 294 my $pxs = ExtUtils::ParseXS->new; 295 tie *FH, 'Foo'; 296 my $stderr = PrimitiveCapture::capture_stderr(sub { 297 $pxs->process_file( 298 filename => 'XSAlias.xs', 299 output => \*FH, 300 prototypes => 1, 301 author_warnings => 0); 302 }); 303 my $content = tied(*FH)->{buf}; 304 my $count = 0; 305 $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg; 306 is $stderr, 307 "Warning: Conflicting duplicate alias 'pox' changes" 308 . " definition from '1' to '2' in XSAlias.xs, line 10\n", 309 "Saw expected warnings from XSAlias.xs"; 310 311 my $expect = quotemeta(<<'EOF_CONTENT'); 312 cv = newXSproto_portable("My::dachs", XS_My_do, file, "$"); 313 XSANY.any_i32 = 1; 314 cv = newXSproto_portable("My::do", XS_My_do, file, "$"); 315 XSANY.any_i32 = 0; 316 cv = newXSproto_portable("My::docks", XS_My_do, file, "$"); 317 XSANY.any_i32 = 1; 318 cv = newXSproto_portable("My::dox", XS_My_do, file, "$"); 319 XSANY.any_i32 = 1; 320 cv = newXSproto_portable("My::lox", XS_My_do, file, "$"); 321 XSANY.any_i32 = 1; 322 cv = newXSproto_portable("My::pox", XS_My_do, file, "$"); 323 XSANY.any_i32 = 2; 324 cv = newXSproto_portable("My::xukes", XS_My_do, file, "$"); 325 XSANY.any_i32 = 0; 326 cv = newXSproto_portable("My::xunx", XS_My_do, file, "$"); 327 XSANY.any_i32 = 0; 328EOF_CONTENT 329 $expect=~s/(?:\\[ ])+/\\s+/g; 330 $expect=qr/$expect/; 331 like $content, $expect, "Saw expected alias initialization"; 332 333 #diag $content; 334} 335{ 336 my $file = $INC{"ExtUtils/ParseXS.pm"}; 337 $file=~s!ExtUtils/ParseXS\.pm\z!perlxs.pod!; 338 open my $fh, "<", $file 339 or die "Failed to open '$file' for read:$!"; 340 my $pod_version = ""; 341 while (defined(my $line= readline($fh))) { 342 if ($line=~/\(also known as C<xsubpp>\)\s+(\d+\.\d+)/) { 343 $pod_version = $1; 344 last; 345 } 346 } 347 close $fh; 348 ok($pod_version, "Found the version from perlxs.pod"); 349 is($pod_version, $ExtUtils::ParseXS::VERSION, 350 "The version in perlxs.pod should match the version of ExtUtils::ParseXS"); 351} 352 353{ 354 my $pxs = ExtUtils::ParseXS->new; 355 tie *FH, 'Foo'; 356 my $exception; 357 my $stderr = PrimitiveCapture::capture_stderr(sub { 358 eval { 359 $pxs->process_file( 360 filename => "XSNoMap.xs", 361 output => \*FH, 362 ); 363 1; 364 } or $exception = $@; 365 }); 366 is($stderr, undef, "should fail to parse"); 367 like($exception, qr/Could not find a typemap for C type 'S \*'/, 368 "check we throw rather than trying to deref '2'"); 369} 370 371##################################################################### 372 373sub Foo::TIEHANDLE { bless {}, 'Foo' } 374sub Foo::PRINT { shift->{buf} .= join '', @_ } 375sub Foo::content { shift->{buf} } 376