Ensure ExtUtils::CBuilder's 04-base.t cleans up its temporary directories.
[perl.git] / dist / 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 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', 'compilet.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', "compilet$obj_ext"),
142     "object_file(): got expected automatically assigned name for object file"
143 );
144
145 SKIP:
146 {
147     skip "Base can't do real compile and link on VMS", 2
148         if $^O eq 'VMS';
149
150     # object filename explicitly assigned
151     $object_file = File::Spec->catfile('t', 'my_special_compilet.o' );
152     is( $object_file,
153         $base->compile(
154             source      => $source_file,
155             object_file => $object_file,
156         ),
157         "compile(): returned object file with specified name"
158     );
159
160     $lib_file = $base->lib_file($object_file);
161     ok( $lib_file, "lib_file() returned true value" );
162 }
163
164 my ($lib, @temps);
165 SKIP:
166 {
167     skip "Base can't link on Win32 or VMS", 4
168         if $^O eq "MSWin32" || $^O eq "VMS";
169     ($lib, @temps) = $base->link(
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, @temps) = $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     ($lib, @temps) = $base->link(
184         lib_file    => $lib_file,
185         objects     => [ $object_file ],
186         module_name => 'compilet',
187     );
188     $lib =~ tr/"'//d; #"
189     is($lib_file, $lib, "lib_file(): got expected value for $lib");
190
191     $lib = $base->link(
192         objects     => $object_file,
193         module_name => 'compilet',
194     );
195     $lib =~ tr/"'//d; #"
196     is($lib_file, $lib, "lib_file(): got expected value for $lib");
197 }
198
199
200 {
201     local $ENV{PERL_CORE} = '' unless $ENV{PERL_CORE};
202     my $include_dir = $base->perl_inc();
203     ok( $include_dir, "perl_inc() returned true value" );
204     ok( -d $include_dir, "perl_inc() returned directory" );
205 }
206
207 #
208 $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
209 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
210 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
211
212 $source_file = File::Spec->catfile('t', 'compilet.c');
213 create_c_source_file($source_file);
214 ok(-e $source_file, "source file '$source_file' created");
215 SKIP:
216 {
217     skip "Base can't do real compile and link on VMS", 2
218         if $^O eq 'VMS';
219
220     $object_file = File::Spec->catfile('t', 'my_special_compilet.o' );
221     is( $object_file,
222         $base->compile(
223             source      => $source_file,
224             object_file => $object_file,
225             defines     => { alpha => 'beta', gamma => 'delta' },
226         ),
227         "compile() completed when 'defines' provided; returned object file with specified name"
228     );
229
230     my $exe_file = $base->exe_file($object_file);
231     my $ext = $base->{config}{_exe};
232     my $expected = File::Spec->catfile('t', qq|my_special_compilet$ext| );
233     is(
234         $exe_file,
235         $expected,
236         "exe_file(): returned expected name of executable"
237     );
238 }
239
240 my %args = ();
241 my @defines = $base->arg_defines( %args );
242 ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" );
243
244 %args = ( alpha => 'beta', gamma => 'delta' );
245 my $defines_seen_ref = { map { $_ => 1 } $base->arg_defines( %args ) };
246 is_deeply(
247     $defines_seen_ref,
248     { '-Dalpha=beta' => 1, '-Dgamma=delta' => 1 },
249     "arg_defines(): got expected defines",
250 );
251
252 my $include_dirs_seen_ref =
253     { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) };
254 is_deeply(
255     $include_dirs_seen_ref,
256     { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 },
257     "arg_include_dirs(): got expected include_dirs",
258 );
259
260 is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" );
261
262 my $seen_ref =
263     { map {$_ => 1} $base->arg_object_file('alpha') };
264 is_deeply(
265     $seen_ref,
266     { '-o'  => 1, 'alpha' => 1 },
267     "arg_object_file(): got expected option flag and value",
268 );
269
270 $seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') };
271 my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags});
272 $exp{'-o'} = 1;
273 $exp{'alpha'} = 1; 
274
275 is_deeply(
276     $seen_ref,
277     \%exp,
278     "arg_share_object_file(): got expected option flag and value",
279 );
280
281 $seen_ref =
282     { map {$_ => 1} $base->arg_exec_file('alpha') };
283 is_deeply(
284     $seen_ref,
285     { '-o'  => 1, 'alpha' => 1 },
286     "arg_exec_file(): got expected option flag and value",
287 );
288
289 ok(! $base->split_like_shell(undef),
290     "split_like_shell(): handled undefined argument as expected" );
291
292 my $array_ref = [ qw| alpha beta gamma | ];
293 my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref);
294 %exp = ( alpha => 1, beta => 1, gamma => 1 );
295 is_deeply( \%split_seen, \%exp,
296     "split_like_shell(): handled array ref as expected" );
297
298 {
299     $cwd = cwd();
300     my $tdir = tempdir(CLEANUP => 1);
301     my $subdir = File::Spec->catdir(
302         $tdir, qw| alpha beta gamma delta epsilon 
303             zeta eta theta iota kappa lambda |
304     );
305     mkpath($subdir, { mode => 0711 } );
306     chdir $subdir
307         or die "Unable to change to temporary directory for testing";
308     local $ENV{PERL_CORE} = 1;
309     my $capture = q{};
310     local $SIG{__WARN__} = sub { $capture = $_[0] };
311     my $expected_message =
312         qr/PERL_CORE is set but I can't find your perl source!/; #'
313     my $rv;
314
315     $rv = $base->perl_src();
316     is( $rv, q{}, "perl_src(): returned empty string as expected" );
317     like( $capture, $expected_message,
318         "perl_src(): got expected warning" );
319     $capture = q{};
320
321     my $config = File::Spec->catfile( $subdir, 'config_h.SH' );
322     touch_file($config);
323     $rv = $base->perl_src();
324     is( $rv, q{}, "perl_src(): returned empty string as expected" );
325     like( $capture, $expected_message,
326         "perl_src(): got expected warning" );
327     $capture = q{};
328
329     my $perlh = File::Spec->catfile( $subdir, 'perl.h' );
330     touch_file($perlh);
331     $rv = $base->perl_src();
332     is( $rv, q{}, "perl_src(): returned empty string as expected" );
333     like( $capture, $expected_message,
334         "perl_src(): got expected warning" );
335     $capture = q{};
336
337     my $libsubdir = File::Spec->catdir( $subdir, 'lib' );
338     mkpath($libsubdir, { mode => 0711 } );
339     my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' );
340     touch_file($exporter);
341     $rv = $base->perl_src();
342     ok( -d $rv, "perl_src(): returned a directory" );
343     is( uc($rv), uc(Cwd::realpath($subdir)), "perl_src(): identified directory" );
344     is( $capture, q{}, "perl_src(): no warning, as expected" );
345
346     chdir $cwd
347         or die "Unable to change from temporary directory after testing";
348 }
349
350 my ($dl_file_out, $mksymlists_args);
351 my $dlf = 'Kappa';
352 %args = (
353     dl_vars         => [ qw| alpha beta gamma | ],
354     dl_funcs        => {
355         'Homer::Iliad'      => [ qw(trojans greeks) ],
356         'Homer::Odyssey'    => [ qw(travellers family suitors) ],
357     },
358     dl_func_list    => [ qw| delta epsilon | ],
359     dl_imports      => { zeta => 'eta', theta => 'iota' },
360     dl_name         => 'Tk::Canvas',
361     dl_base         => 'Tk::Canvas.ext',
362     dl_file         => $dlf,
363     dl_version      => '7.7',
364 );
365 ($dl_file_out, $mksymlists_args) =
366     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
367 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" );
368 is_deeply( $mksymlists_args,
369     {
370         DL_VARS         => [ qw| alpha beta gamma | ],
371         DL_FUNCS        => {
372             'Homer::Iliad'      => [ qw(trojans greeks) ],
373             'Homer::Odyssey'    => [ qw(travellers family suitors) ],
374         },
375         FUNCLIST        => [ qw| delta epsilon | ],
376         IMPORTS         => { zeta => 'eta', theta => 'iota' },
377         NAME            => 'Tk::Canvas',
378         DLBASE          => 'Tk::Canvas.ext',
379         FILE            => $dlf,
380         VERSION         => '7.7',
381     },
382     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
383 );
384
385 $dlf = 'Canvas';
386 %args = (
387     dl_name         => 'Tk::Canvas',
388     dl_base         => 'Tk::Canvas.ext',
389 );
390 ($dl_file_out, $mksymlists_args) =
391     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
392 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" );
393 is_deeply( $mksymlists_args,
394     {
395         DL_VARS         => [],
396         DL_FUNCS        => {},
397         FUNCLIST        => [],
398         IMPORTS         => {},
399         NAME            => 'Tk::Canvas',
400         DLBASE          => 'Tk::Canvas.ext',
401         FILE            => $dlf,
402         VERSION         => '0.0',
403     },
404     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
405 );
406
407 #####
408
409 for ($source_file, $object_file, $lib_file) {
410   next unless defined $_;
411   tr/"'//d; #"
412   1 while unlink;
413 }
414
415 pass("Completed all tests in $0");
416
417 if ($^O eq 'VMS') {
418    1 while unlink 'COMPILET.LIS';
419    1 while unlink 'COMPILET.OPT';
420 }
421
422 sub create_c_source_file {
423     my $source_file = shift;
424     open my $FH, '>', $source_file or die "Can't create $source_file: $!";
425     print $FH "int boot_compilet(void) { return 1; }\n";
426     close $FH;
427 }
428
429 sub touch_file {
430     my $f = shift;
431     open my $FH, '>', $f or die "Can't create $f: $!";
432     print $FH "\n";
433     close $FH;
434     return $f;
435 }