This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Impose deterministic order on cpp-definition options.
[perl5.git] / dist / ExtUtils-CBuilder / t / 04-base.t
1 #! perl -w
2
3 use strict;
4 use Test::More tests => 65;
5 use Config;
6 use Cwd;
7 use File::Path qw( mkpath );
8 use File::Temp qw( tempdir );
9 use ExtUtils::CBuilder::Base;
10
11 ## N.B.  There are pretty severe limits on what can portably be tested
12 ## in the base class.  Specifically, don't do anything that will send
13 ## actual compile and link commands to the shell as that won't work
14 ## without the platform-specific overrides.
15
16 # XXX protect from user CC as we mock everything here
17 local $ENV{CC};
18
19 my ( $base, $phony, $cwd );
20 my ( $source_file, $object_file, $lib_file );
21
22 $base = ExtUtils::CBuilder::Base->new();
23 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
24 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
25
26 {
27   $phony = 'foobar';
28   $base = ExtUtils::CBuilder::Base->new(
29       config  => { cc => $phony },
30   );
31   ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
32   isa_ok( $base, 'ExtUtils::CBuilder::Base' );
33   is( $base->{config}->{cc}, $phony,
34       "Got expected value when 'config' argument passed to new()" );
35 }
36
37 {
38     $phony = 'barbaz';
39     local $ENV{CC} = $phony;
40     $base = ExtUtils::CBuilder::Base->new();
41     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
42     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
43     is( $base->{config}->{cc}, $phony,
44         "Got expected value \$ENV{CC} set" );
45 }
46
47 {
48     my $path_to_perl = $^O eq 'VMS'
49                        ? 'perl_root:[000000]perl.exe'
50                        : File::Spec->catfile( '', qw| usr bin perl | );
51     local $^X = $path_to_perl;
52     is(
53         ExtUtils::CBuilder::Base::find_perl_interpreter(),
54         $path_to_perl,
55         "find_perl_interpreter() returned expected absolute path"
56     );
57 }
58
59 SKIP:
60 {
61     skip "Base doesn't know about override on VMS", 1
62         if $^O eq 'VMS';
63
64     my $path_to_perl = 'foobar';
65     local $^X = $path_to_perl;
66     # %Config is read-only.  We cannot assign to it and we therefore cannot
67     # simulate the condition that would occur were its value something other
68     # than an existing file.
69     if ( !$ENV{PERL_CORE} and $Config::Config{perlpath}) {
70         is(
71             ExtUtils::CBuilder::Base::find_perl_interpreter(),
72             $Config::Config{perlpath},
73             "find_perl_interpreter() returned expected file"
74         );
75     }
76     else {
77         local $^X = $path_to_perl = File::Spec->rel2abs($path_to_perl);
78         is(
79             ExtUtils::CBuilder::Base::find_perl_interpreter(),
80             $path_to_perl,
81             "find_perl_interpreter() returned expected name"
82         );
83     }
84 }
85
86 {
87     $cwd = cwd();
88     my $tdir = tempdir(CLEANUP => 1);
89     chdir $tdir;
90     $base = ExtUtils::CBuilder::Base->new();
91     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
92     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
93     is( scalar keys %{$base->{files_to_clean}}, 0,
94         "No files needing cleaning yet" );
95
96     my $file_for_cleaning = File::Spec->catfile( $tdir, 'foobar' );
97     open my $IN, '>', $file_for_cleaning
98         or die "Unable to open dummy file: $!";
99     print $IN "\n";
100     close $IN or die "Unable to close dummy file: $!";
101
102     $base->add_to_cleanup( $file_for_cleaning );
103     is( scalar keys %{$base->{files_to_clean}}, 1,
104         "One file needs cleaning" );
105
106     $base->cleanup();
107     ok( ! -f $file_for_cleaning, "File was cleaned up" );
108
109     chdir $cwd;
110 }
111
112 # fake compiler is perl and will always succeed
113 $base = ExtUtils::CBuilder::Base->new(
114     config  => {
115         cc => File::Spec->rel2abs($^X) . " -e1 --",
116         ld => File::Spec->rel2abs($^X) . " -e1 --",
117     }
118 );
119 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
120 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
121 eval {
122     $base->compile(foo => 'bar');
123 };
124 like(
125     $@,
126     qr/Missing 'source' argument to compile/,
127     "Got expected error message when lacking 'source' argument to compile()"
128 );
129
130 $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
131 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
132 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
133
134 $source_file = File::Spec->catfile('t', 'baset.c');
135 create_c_source_file($source_file);
136 ok(-e $source_file, "source file '$source_file' created");
137
138 # object filename automatically assigned
139 my $obj_ext = $base->{config}{obj_ext};
140 is( $base->object_file($source_file),
141     File::Spec->catfile('t', "baset$obj_ext"),
142     "object_file(): got expected automatically assigned name for object file"
143 );
144
145 my ($lib, @temps);
146
147
148 {
149     local $ENV{PERL_CORE} = '' unless $ENV{PERL_CORE};
150     my $include_dir = $base->perl_inc();
151     ok( $include_dir, "perl_inc() returned true value" );
152     ok( -d $include_dir, "perl_inc() returned directory" );
153 }
154
155 $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
156 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
157 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
158
159 $source_file = File::Spec->catfile('t', 'baset.c');
160 create_c_source_file($source_file);
161 ok(-e $source_file, "source file '$source_file' created");
162
163 my %args = ();
164 my @defines = $base->arg_defines( %args );
165 ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" );
166
167 my @epsilon = ( epsilon => 'zeta' );
168 my @eta     = ( eta => 'theta' );
169 my @alpha   = ( alpha => 'beta' );
170 my @gamma   = ( gamma => 'delta' );
171 my @all = (\@epsilon, \@eta, \@alpha, \@gamma);
172
173 %args = map { @{$_} } @all;
174 @defines = $base->arg_defines( %args );
175 my $defines_seen_ref = { map { $_ => 1 } @defines };
176 my $defines_expected_ref;
177 for my $r (@all) {
178     $defines_expected_ref->{"-D$r->[0]=$r->[1]"} = 1;
179 }
180 is_deeply(
181     $defines_seen_ref,
182     $defines_expected_ref,
183     "arg_defines(): got expected defines",
184 );
185 my $ordered_defines_expected_ref = [ sort keys %{$defines_expected_ref} ];
186 is_deeply(\@defines, $ordered_defines_expected_ref,
187     "Got expected order of defines: RT #124106");
188
189 my $include_dirs_seen_ref =
190     { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) };
191 is_deeply(
192     $include_dirs_seen_ref,
193     { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 },
194     "arg_include_dirs(): got expected include_dirs",
195 );
196
197 is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" );
198
199 my $seen_ref =
200     { map {$_ => 1} $base->arg_object_file('alpha') };
201 is_deeply(
202     $seen_ref,
203     { '-o'  => 1, 'alpha' => 1 },
204     "arg_object_file(): got expected option flag and value",
205 );
206
207 $seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') };
208 my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags});
209 $exp{'-o'} = 1;
210 $exp{'alpha'} = 1;
211
212 is_deeply(
213     $seen_ref,
214     \%exp,
215     "arg_share_object_file(): got expected option flag and value",
216 );
217
218 $seen_ref =
219     { map {$_ => 1} $base->arg_exec_file('alpha') };
220 is_deeply(
221     $seen_ref,
222     { '-o'  => 1, 'alpha' => 1 },
223     "arg_exec_file(): got expected option flag and value",
224 );
225
226 ok(! $base->split_like_shell(undef),
227     "split_like_shell(): handled undefined argument as expected" );
228
229 my $array_ref = [ qw| alpha beta gamma | ];
230 my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref);
231 %exp = ( alpha => 1, beta => 1, gamma => 1 );
232 is_deeply( \%split_seen, \%exp,
233     "split_like_shell(): handled array ref as expected" );
234
235 {
236     $cwd = cwd();
237     my $tdir = tempdir(CLEANUP => 1);
238     my $subdir = File::Spec->catdir(
239         $tdir, qw| alpha beta gamma delta epsilon
240             zeta eta theta iota kappa lambda |
241     );
242     mkpath($subdir, { mode => 0711 } );
243     chdir $subdir
244         or die "Unable to change to temporary directory for testing";
245     local $ENV{PERL_CORE} = 1;
246     my $capture = q{};
247     local $SIG{__WARN__} = sub { $capture = $_[0] };
248     my $expected_message =
249         qr/PERL_CORE is set but I can't find your perl source!/; #'
250     my $rv;
251
252     $rv = $base->perl_src();
253     is( $rv, q{}, "perl_src(): returned empty string as expected" );
254     like( $capture, $expected_message,
255         "perl_src(): got expected warning" );
256     $capture = q{};
257
258     my $config = File::Spec->catfile( $subdir, 'config_h.SH' );
259     touch_file($config);
260     $rv = $base->perl_src();
261     is( $rv, q{}, "perl_src(): returned empty string as expected" );
262     like( $capture, $expected_message,
263         "perl_src(): got expected warning" );
264     $capture = q{};
265
266     my $perlh = File::Spec->catfile( $subdir, 'perl.h' );
267     touch_file($perlh);
268     $rv = $base->perl_src();
269     is( $rv, q{}, "perl_src(): returned empty string as expected" );
270     like( $capture, $expected_message,
271         "perl_src(): got expected warning" );
272     $capture = q{};
273
274     my $libsubdir = File::Spec->catdir( $subdir, 'lib' );
275     mkpath($libsubdir, { mode => 0711 } );
276     my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' );
277     touch_file($exporter);
278     $rv = $base->perl_src();
279     ok( -d $rv, "perl_src(): returned a directory" );
280     my $rp = Cwd::realpath($subdir);
281   SKIP: {
282       if ($^O eq 'dec_osf' && $rp =~ m[^/cluster/members/]) {
283           skip "Tru64 cluster filesystem", 1;
284       } # SKIP
285       elsif ($^O eq 'os390') {
286         # os390 also has cluster-like things called 'sysplexed'.  So far, the
287         # tail end of the path matches what we passed it (with some prepended
288         # directories).  So test for that.
289         like( uc($rp), qr/\U\Q$rp\E$/, "perl_src(): identified directory" );
290       }
291       else {
292         is( uc($rv), uc($rp), "perl_src(): identified directory" );
293       }
294     }
295     is( $capture, q{}, "perl_src(): no warning, as expected" );
296
297     chdir $cwd
298         or die "Unable to change from temporary directory after testing";
299 }
300
301 my ($dl_file_out, $mksymlists_args);
302 my $dlf = 'Kappa';
303 %args = (
304     dl_vars         => [ qw| alpha beta gamma | ],
305     dl_funcs        => {
306         'Homer::Iliad'      => [ qw(trojans greeks) ],
307         'Homer::Odyssey'    => [ qw(travellers family suitors) ],
308     },
309     dl_func_list    => [ qw| delta epsilon | ],
310     dl_imports      => { zeta => 'eta', theta => 'iota' },
311     dl_name         => 'Tk::Canvas',
312     dl_base         => 'Tk::Canvas.ext',
313     dl_file         => $dlf,
314     dl_version      => '7.7',
315 );
316 ($dl_file_out, $mksymlists_args) =
317     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
318 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" );
319 is_deeply( $mksymlists_args,
320     {
321         DL_VARS         => [ qw| alpha beta gamma | ],
322         DL_FUNCS        => {
323             'Homer::Iliad'      => [ qw(trojans greeks) ],
324             'Homer::Odyssey'    => [ qw(travellers family suitors) ],
325         },
326         FUNCLIST        => [ qw| delta epsilon | ],
327         IMPORTS         => { zeta => 'eta', theta => 'iota' },
328         NAME            => 'Tk::Canvas',
329         DLBASE          => 'Tk::Canvas.ext',
330         FILE            => $dlf,
331         VERSION         => '7.7',
332     },
333     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
334 );
335
336 $dlf = 'Canvas';
337 %args = (
338     dl_name         => 'Tk::Canvas',
339     dl_base         => 'Tk::Canvas.ext',
340 );
341 ($dl_file_out, $mksymlists_args) =
342     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
343 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" );
344 is_deeply( $mksymlists_args,
345     {
346         DL_VARS         => [],
347         DL_FUNCS        => {},
348         FUNCLIST        => [],
349         IMPORTS         => {},
350         NAME            => 'Tk::Canvas',
351         DLBASE          => 'Tk::Canvas.ext',
352         FILE            => $dlf,
353         VERSION         => '0.0',
354     },
355     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
356 );
357
358 my %testvars = (
359     CFLAGS  => 'ccflags',
360     LDFLAGS => 'ldflags',
361 );
362
363 while (my ($VAR, $var) = each %testvars) {
364     local $ENV{$VAR};
365     $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
366     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
367     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
368     like($base->{config}{$var}, qr/\Q$Config{$var}/,
369         "honours $var from Config.pm");
370
371     $ENV{$VAR} = "-foo -bar";
372     $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
373     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
374     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
375     like($base->{config}{$var}, qr/\Q$ENV{$VAR}/,
376         "honours $VAR from the environment");
377     like($base->{config}{$var}, qr/\Q$Config{$var}/,
378         "doesn't override $var from Config.pm with $VAR from the environment");
379 }
380
381 #####
382
383 for ($source_file, $object_file, $lib_file) {
384   next unless defined $_;
385   tr/"'//d; #"
386   1 while unlink;
387 }
388
389 pass("Completed all tests in $0");
390
391 if ($^O eq 'VMS') {
392    1 while unlink 'BASET.LIS';
393    1 while unlink 'BASET.OPT';
394 }
395
396 sub create_c_source_file {
397     my $source_file = shift;
398     open my $FH, '>', $source_file or die "Can't create $source_file: $!";
399     print $FH "int boot_baset(void) { return 1; }\n";
400     close $FH;
401 }
402
403 sub touch_file {
404     my $f = shift;
405     open my $FH, '>', $f or die "Can't create $f: $!";
406     print $FH "\n";
407     close $FH;
408     return $f;
409 }