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