xref: /openbsd-src/gnu/usr.bin/perl/dist/ExtUtils-ParseXS/t/001-basic.t (revision f2a19305cfc49ea4d1a5feb55cd6c283c6f1e031)
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