dist/ExtUtils-ParseXS/t/001-basic.t

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