1package MakeMaker::Test::Setup::XS;
2
3@ISA = qw(Exporter);
4require Exporter;
5@EXPORT = qw(run_tests list_dynamic list_static);
6
7use strict;
8use warnings;
9use File::Path;
10use MakeMaker::Test::Utils;
11use Config;
12use Carp qw(croak);
13use Test::More;
14use File::Spec;
15
16use File::Temp qw[tempdir];
17use Cwd;
18use ExtUtils::MM;
19# this is to avoid MM->new overwriting _eumm in top dir
20my $tempdir = tempdir(DIR => getcwd, CLEANUP => 1);
21chdir $tempdir;
22my $typemap = 'type map';
23my $MM = MM->new({NAME=>'name', NORECURS=>1});
24$typemap =~ s/ //g unless $MM->can_dep_space;
25chdir File::Spec->updir;
26
27my $PM_TEST = <<'END';
28package XS::Test;
29require Exporter;
30require DynaLoader;
31$VERSION = 1.01;
32@ISA    = qw(Exporter DynaLoader);
33@EXPORT = qw(is_even);
34bootstrap XS::Test $VERSION;
351;
36END
37
38my $XS_TEST = <<'END';
39#include "EXTERN.h"
40#include "perl.h"
41#include "XSUB.h"
42MODULE = XS::Test       PACKAGE = XS::Test
43PROTOTYPES: DISABLE
44int
45is_even(input)
46       int     input
47   CODE:
48       RETVAL = (input % 2 == 0);
49   OUTPUT:
50       RETVAL
51END
52
53my $T_TEST = <<'END';
54#!/usr/bin/perl -w
55use Test::More tests => 3;
56use_ok "XS::Test";
57ok !is_even(1);
58ok is_even(2);
59END
60
61my $MAKEFILEPL = <<'END';
62use ExtUtils::MakeMaker;
63WriteMakefile(
64  NAME          => 'XS::%s',
65  VERSION_FROM  => '%s',
66  TYPEMAPS      => [ %s ],
67  PERL          => "$^X -w",
68  %s
69);
70END
71
72my $BS_TEST = '$DynaLoader::bscode = q(warn "BIG NOISE";)';
73
74my $T_BOOTSTRAP = <<'EOF';
75use Test::More tests => 1;
76my $w = '';
77$SIG{__WARN__} = sub { $w .= join '', @_; };
78require XS::Test;
79like $w, qr/NOISE/;
80EOF
81
82my $PM_OTHER = <<'END';
83package XS::Other;
84require Exporter;
85require DynaLoader;
86$VERSION = 1.20;
87@ISA    = qw(Exporter DynaLoader);
88@EXPORT = qw(is_odd);
89bootstrap XS::Other $VERSION;
901;
91END
92
93my $XS_OTHER = <<'END';
94#include "EXTERN.h"
95#include "perl.h"
96#include "XSUB.h"
97MODULE = XS::Other       PACKAGE = XS::Other
98PROTOTYPES: DISABLE
99int
100is_odd(input)
101       int     input
102   CODE:
103       RETVAL = (INVAR % 2 == 1);
104   OUTPUT:
105       RETVAL
106END
107
108my $T_OTHER = <<'END';
109#!/usr/bin/perl -w
110use Test::More tests => 3;
111use_ok "XS::Other";
112ok is_odd(1);
113ok !is_odd(2);
114END
115
116my $PLUS1_C = <<'EOF';
117#ifdef __cplusplus
118extern "C" {
119int plus1(int i)
120#else
121int plus1(i)
122int i;
123#endif
124{ return i + 1; }
125#ifdef __cplusplus
126}
127#endif
128EOF
129
130my %Files = (
131  'lib/XS/Test.pm' => $PM_TEST,
132  $typemap => '',
133  'Test.xs' => $XS_TEST,
134  't/is_even.t' => $T_TEST,
135  'Makefile.PL' => sprintf($MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'}, ''),
136);
137
138my %label2files = (basic => \%Files, basic2 => \%Files); # basic2 so no clash
139
140$label2files{bscode} = +{
141  %{ $label2files{'basic'} }, # make copy
142  'Test_BS' => $BS_TEST,
143  't/bs.t' => $T_BOOTSTRAP,
144};
145delete $label2files{bscode}->{'t/is_even.t'};
146
147$label2files{static} = +{
148  %{ $label2files{'basic'} }, # make copy
149  'Makefile.PL' => sprintf(
150    $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
151    q{LINKTYPE => 'static'},
152  ),
153  "blib/arch/auto/share/dist/x-y/libwhatevs$MM->{LIB_EXT}" => 'hi there', # mimic what File::ShareDir can do
154  "blib/arch/auto/Alien/ROOT/root/lib/root/root$MM->{LIB_EXT}" => 'hi there', # mimic Alien::ROOT that installs a .a without extralibs.ld
155  # next two mimic dist that installs a .a WITH extralibs.ld but that is still not XS
156  "blib/arch/auto/Dist/File$MM->{LIB_EXT}" => 'hi there',
157  "blib/arch/auto/Dist/extralibs.ld" => '',
158};
159
160$label2files{subdirs} = +{
161  %{ $label2files{'basic'} }, # make copy
162  'Makefile.PL' => sprintf(
163    $MAKEFILEPL, 'Test', 'Test.pm', qq{'$typemap'},
164    q{DEFINE => '-DINVAR=input', INC => "-Inewline\n", LIBS => "-Lnewline\n",},
165  ),
166  'Other/Makefile.PL' => sprintf($MAKEFILEPL, 'Other', 'Other.pm', qq{}, ''),
167  'Other/Other.pm' => $PM_OTHER,
168  'Other/Other.xs' => $XS_OTHER,
169  't/is_odd.t' => $T_OTHER,
170};
171virtual_rename('subdirs', 'lib/XS/Test.pm', 'Test.pm');
172
173# to mimic behaviour of Unicode-LineBreak version 2015.07.16
174$label2files{subdirscomplex} = +{
175  %{ $label2files{'subdirs'} }, # make copy
176  'Other/Makefile.PL' => sprintf(
177    $MAKEFILEPL,
178    'Other', 'Other.pm', qq{},
179    <<'EOF',
180C => [qw(lib$(DIRFILESEP)file.c)],
181OBJECT => 'lib$(DIRFILESEP)file$(OBJ_EXT)',
182EOF
183  ) . <<'EOF',
184sub MY::c_o {
185  package MY;
186  my $self = shift;
187  my $inherited = $self->SUPER::c_o(@_);
188  $inherited =~ s{(:\n\t)(.*(?:\n\t.*)*)}
189      { $1 . $self->cd('lib', split /(?<!\\)\n\t/, $2) }eg;
190  $inherited =~ s{(\s)(\$\*\.c\s)}
191      { "$1..\$(DIRFILESEP)$2" }eg;
192  $inherited;
193}
194
195sub MY::top_targets {
196  <<'SNIP';
197all :: lib$(DIRFILESEP)file$(OBJ_EXT)
198	$(NOECHO) $(NOOP)
199
200config ::
201	$(NOECHO) $(NOOP)
202
203pure_all ::
204	$(NOECHO) $(NOOP)
205SNIP
206}
207EOF
208  'Other/lib/file.c' => $PLUS1_C,
209};
210delete $label2files{subdirscomplex}{'Other/Other.xs'};
211delete $label2files{subdirscomplex}{'t/is_odd.t'};
212
213$label2files{subdirsstatic} = +{
214  %{ $label2files{'subdirs'} }, # make copy
215  'Makefile.PL' => sprintf(
216    $MAKEFILEPL, 'Test', 'Test.pm', qq{'$typemap'},
217    q{DEFINE => '-DINVAR=input', LINKTYPE => 'static',},
218  ),
219};
220
221# to mimic behaviour of CGI-Deurl-XS version 0.08
222my $OTHERMAKEFILE = File::Spec->catfile('Other', makefile_name());
223$label2files{subdirsskip} = +{
224  %{ $label2files{subdirscomplex} }, # make copy
225  'Makefile.PL' => sprintf(
226    $MAKEFILEPL,
227    'Test', 'Test.pm', qq{},
228    q[
229MYEXTLIB => '] . File::Spec->catfile('Other', 'libparser$(LIB_EXT)') . q[',
230     ]
231  )
232  . q[
233sub MY::postamble {
234    my ($self) = @_;
235    return '$(MYEXTLIB) : ] . $OTHERMAKEFILE . q['."\n\t".$self->cd('Other', '$(MAKE) $(PASSTHRU)')."\n";
236}
237     ],
238  'Other/Makefile.PL' => sprintf(
239    $MAKEFILEPL,
240    'Other', 'Other.pm', qq{},
241    <<'EOF',
242SKIP   => [qw(all static dynamic )],
243clean  => {'FILES' => 'libparser$(LIB_EXT)'},
244EOF
245  ) . <<'EOF',
246sub MY::top_targets {
247  my ($self) = @_;
248  my $static_lib_pure_cmd = $self->static_lib_pure_cmd('$(O_FILES)');
249  <<'SNIP' . $static_lib_pure_cmd;
250all :: static
251
252pure_all :: static
253
254static :: libparser$(LIB_EXT)
255
256libparser$(LIB_EXT): $(O_FILES)
257SNIP
258}
259EOF
260  't/plus1.t' => <<'END',
261#!/usr/bin/perl -w
262use Test::More tests => 2;
263use_ok "XS::Test";
264is XS::Test::plus1(3), 4;
265END
266  'Test.xs' => <<EOF,
267#ifdef __cplusplus
268extern "C" {
269#endif
270int plus1(int);
271#ifdef __cplusplus
272}
273#endif
274$XS_TEST
275int
276plus1(input)
277       int     input
278   CODE:
279       RETVAL = plus1(input);
280   OUTPUT:
281       RETVAL
282EOF
283};
284virtual_rename('subdirsskip', 'Other/lib/file.c', 'Other/file.c');
285
286my $XS_MULTI = $XS_OTHER;
287# check compiling from top dir still can include local
288$XS_MULTI =~ s:(#include "XSUB.h"):$1\n#include "header.h":;
289$label2files{multi} = +{
290  %{ $label2files{'basic'} }, # make copy
291  'Makefile.PL' => sprintf(
292    $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'lib/XS/$typemap'},
293    q{XSMULTI => 1,},
294  ),
295  'lib/XS/Other.pm' => $PM_OTHER,
296  'lib/XS/Other.xs' => $XS_MULTI,
297  't/is_odd.t' => $T_OTHER,
298  'lib/XS/header.h' => "#define INVAR input\n",
299};
300virtual_rename('multi', $typemap, "lib/XS/$typemap");
301virtual_rename('multi', 'Test.xs', 'lib/XS/Test.xs');
302
303$label2files{bscodemulti} = +{
304  %{ $label2files{'multi'} }, # make copy
305  'lib/XS/Test_BS' => $BS_TEST,
306  't/bs.t' => $T_BOOTSTRAP,
307};
308delete $label2files{bscodemulti}->{'t/is_even.t'};
309delete $label2files{bscodemulti}->{'t/is_odd.t'};
310
311$label2files{staticmulti} = +{
312  %{ $label2files{'multi'} }, # make copy
313  'Makefile.PL' => sprintf(
314    $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
315    q{LINKTYPE => 'static', XSMULTI => 1,},
316  ),
317};
318
319$label2files{xsbuild} = +{
320  %{ $label2files{'multi'} }, # make copy
321  'Makefile.PL' => sprintf(
322    $MAKEFILEPL, 'Test', 'lib/XS/Test.pm', qq{'$typemap'},
323    q{
324      XSMULTI => 1,
325      XSBUILD => {
326        xs => {
327          'lib/XS/Other' => {
328            DEFINE => '-DINVAR=input',
329            OBJECT => 'lib/XS/Other$(OBJ_EXT) lib/XS/plus1$(OBJ_EXT)'
330          }
331        },
332      },
333    },
334  ),
335
336  'lib/XS/Other.xs' => <<EOF,
337#ifdef __cplusplus
338extern "C" {
339#endif
340int plus1(int);
341#ifdef __cplusplus
342}
343#endif
344$XS_OTHER
345int
346plus1(input)
347       int     input
348   CODE:
349       RETVAL = plus1(INVAR);
350   OUTPUT:
351       RETVAL
352EOF
353
354  'lib/XS/plus1.c' => $PLUS1_C,
355
356  't/is_odd.t' => <<'END',
357#!/usr/bin/perl -w
358use Test::More tests => 4;
359use_ok "XS::Other";
360ok is_odd(1);
361ok !is_odd(2);
362is XS::Other::plus1(3), 4;
363END
364
365};
366
367sub virtual_rename {
368  my ($label, $oldfile, $newfile) = @_;
369  $label2files{$label}->{$newfile} = delete $label2files{$label}->{$oldfile};
370}
371
372sub setup_xs {
373  my ($label, $sublabel) = @_;
374  croak "Must supply label" unless defined $label;
375  my $files = $label2files{$label};
376  croak "Must supply valid label" unless defined $files;
377  croak "Must supply sublabel" unless defined $sublabel;
378  my $prefix = "XS-Test$label$sublabel";
379  hash2files($prefix, $files);
380  return $prefix;
381}
382
383sub list_static {
384  (
385    ( !$Config{usedl} ? [ 'basic2', '', '' ] : ()), # still needs testing on static perl
386    [ 'static', '', '' ],
387    [ 'basic', ' static', '_static' ],
388    [ 'multi', ' static', '_static' ],
389    [ 'subdirs', ' LINKTYPE=static', ' LINKTYPE=static' ],
390    [ 'subdirsstatic', '', '' ],
391    [ 'staticmulti', '', '' ],
392  );
393}
394
395sub list_dynamic {
396  (
397    [ 'basic', '', '' ],
398    $^O ne 'MSWin32' ? (
399        [ 'bscode', '', '' ],
400        [ 'bscodemulti', '', '' ],
401        $^O !~ m!^(VMS|aix)$! ? ([ 'subdirscomplex', '', '' ]) : (),
402    ) : (), # DynaLoader different
403    [ 'subdirs', '', '' ],
404    # https://github.com/Perl/perl5/issues/17601
405    # https://rt.cpan.org/Ticket/Display.html?id=115321
406    $^O ne 'MSWin32' ? (
407        [ 'subdirsstatic', ' LINKTYPE=dynamic', ' LINKTYPE=dynamic' ],
408        [ 'subdirsstatic', ' dynamic', '_dynamic' ],
409    ) : (),
410    [ 'multi', '', '' ],
411    $^O ne 'MSWin32' ? (
412        [ 'staticmulti', ' LINKTYPE=dynamic', ' LINKTYPE=dynamic' ],
413        [ 'staticmulti', ' dynamic', '_dynamic' ],
414    ) : (),
415    [ 'xsbuild', '', '' ],
416    [ 'subdirsskip', '', '' ],
417  );
418}
419
420sub run_tests {
421  my ($perl, $label, $add_target, $add_testtarget) = @_;
422  my $sublabel = $add_target;
423  $sublabel =~ s#[\s=]##g;
424  ok( my $dir = setup_xs($label, $sublabel), "setup $label$sublabel" );
425
426  ok( chdir($dir), "chdir'd to $dir" ) || diag("chdir failed: $!");
427
428  my @mpl_out = run(qq{$perl Makefile.PL});
429  SKIP: {
430    unless (cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' )) {
431      diag(@mpl_out);
432      skip 'perl Makefile.PL failed', 2;
433    }
434
435    my $make = make_run();
436    my $target = '';
437    my %macros = ();
438    if (defined($add_target)) {
439        if ($add_target =~ m/(\S+)=(\S+)/) {
440            $macros{$1} = $2;
441        }
442        else {
443            $target = $add_target;
444        }
445    }
446    my $make_cmd = make_macro($make, $target, %macros);
447    my $make_out = run($make_cmd);
448    unless (is( $?, 0, "$make_cmd exited normally" )) {
449        diag $make_out;
450        skip 'Make failed - skipping test', 1;
451    }
452
453    $target = 'test';
454    %macros = ();
455    if (defined($add_testtarget) && length($add_testtarget)) {
456        if ($add_testtarget =~ m/(\S+)=(\S+)/) {
457            $macros{$1} = $2;
458        }
459        else {
460            # an underscore prefix means combine, e.g. 'test' + '_dynamic'
461            unless ($add_testtarget =~ m/^_/) {
462                $target .= ($make =~ m/^MM(K|S)/i) ? ',' : ' ';
463            }
464            $target .= $add_testtarget;
465        }
466    }
467    my $test_cmd = make_macro($make, $target, %macros);
468    my $test_out = run($test_cmd);
469    is( $?, 0, "$test_cmd exited normally" ) || diag "$make_out\n$test_out";
470  }
471
472  chdir File::Spec->updir or die;
473  if ($ENV{EUMM_KEEP_TESTDIRS}) {
474    ok 1, "don't teardown $dir";
475  } else {
476    ok rmtree($dir), "teardown $dir";
477  }
478}
479
4801;
481