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