1package ExtUtils::CBuilder::Base;
2use strict;
3use warnings;
4use File::Spec;
5use File::Basename;
6use Cwd ();
7use Config;
8use Text::ParseWords;
9use IPC::Cmd qw(can_run);
10use File::Temp qw(tempfile);
11
12our $VERSION = '0.280240'; # VERSION
13
14# More details about C/C++ compilers:
15# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp
16# http://gcc.gnu.org/
17# http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp
18# http://msdn.microsoft.com/en-us/vstudio/default.aspx
19
20my %cc2cxx = (
21    # first line order is important to support wrappers like in pkgsrc
22    cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers
23    gcc => [ 'g++' ], # GNU Compiler Collection
24    xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety
25    xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety
26    cl    => [ 'cl' ], # Microsoft Visual Studio
27);
28
29sub new {
30  my $class = shift;
31  my $self = bless {@_}, $class;
32
33  $self->{properties}{perl} = $class->find_perl_interpreter
34    or warn "Warning: Can't locate your perl binary";
35
36  while (my ($k,$v) = each %Config) {
37    $self->{config}{$k} = $v unless exists $self->{config}{$k};
38  }
39  $self->{config}{cc} = $ENV{CC} if defined $ENV{CC};
40  $self->{config}{ccflags} = join(" ", $self->{config}{ccflags}, $ENV{CFLAGS})
41     if defined $ENV{CFLAGS};
42  $self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX};
43  $self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS};
44  $self->{config}{ld} = $ENV{LD} if defined $ENV{LD};
45  $self->{config}{ldflags} = join(" ", $self->{config}{ldflags}, $ENV{LDFLAGS})
46     if defined $ENV{LDFLAGS};
47
48  unless ( exists $self->{config}{cxx} ) {
49
50    my ($ccbase, $ccpath, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/);
51
52    ## If the path is just "cc", fileparse returns $ccpath as "./"
53    $ccpath = "" if $self->{config}{cc} =~ /^\Q$ccbase$ccsfx\E$/;
54
55    foreach my $cxx (@{$cc2cxx{$ccbase}}) {
56      my $cxx1 = File::Spec->catfile( $ccpath, $cxx . $ccsfx);
57
58      if( can_run( $cxx1 ) ) {
59        $self->{config}{cxx} = $cxx1;
60	last;
61      }
62      my $cxx2 = $cxx . $ccsfx;
63
64      if( can_run( $cxx2 ) ) {
65        $self->{config}{cxx} = $cxx2;
66	last;
67      }
68
69      if( can_run( $cxx ) ) {
70        $self->{config}{cxx} = $cxx;
71	last;
72      }
73    }
74    unless ( exists $self->{config}{cxx} ) {
75      $self->{config}{cxx} = $self->{config}{cc};
76      my $cflags = $self->{config}{ccflags};
77      $self->{config}{cxxflags} = '-x c++';
78      $self->{config}{cxxflags} .= " $cflags" if defined $cflags;
79    }
80  }
81
82  return $self;
83}
84
85sub find_perl_interpreter {
86  my $perl;
87  File::Spec->file_name_is_absolute($perl = $^X)
88    or -f ($perl = $Config::Config{perlpath})
89    or ($perl = $^X); # XXX how about using IPC::Cmd::can_run here?
90  return $perl;
91}
92
93sub add_to_cleanup {
94  my $self = shift;
95  foreach (@_) {
96    $self->{files_to_clean}{$_} = 1;
97  }
98}
99
100sub cleanup {
101  my $self = shift;
102  foreach my $file (keys %{$self->{files_to_clean}}) {
103    unlink $file;
104  }
105}
106
107sub get_config {
108    return %{ $_[0]->{config} };
109}
110
111sub object_file {
112  my ($self, $filename) = @_;
113
114  # File name, minus the suffix
115  (my $file_base = $filename) =~ s/\.[^.]+$//;
116  return "$file_base$self->{config}{obj_ext}";
117}
118
119sub arg_include_dirs {
120  my $self = shift;
121  return map {"-I$_"} @_;
122}
123
124sub arg_nolink { '-c' }
125
126sub arg_object_file {
127  my ($self, $file) = @_;
128  return ('-o', $file);
129}
130
131sub arg_share_object_file {
132  my ($self, $file) = @_;
133  return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file);
134}
135
136sub arg_exec_file {
137  my ($self, $file) = @_;
138  return ('-o', $file);
139}
140
141sub arg_defines {
142  my ($self, %args) = @_;
143  return map "-D$_=$args{$_}", sort keys %args;
144}
145
146sub compile {
147  my ($self, %args) = @_;
148  die "Missing 'source' argument to compile()" unless defined $args{source};
149
150  my $cf = $self->{config}; # For convenience
151
152  my $object_file = $args{object_file}
153    ? $args{object_file}
154    : $self->object_file($args{source});
155
156  my $include_dirs_ref =
157    (exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY")
158      ? [ $args{include_dirs} ]
159      : $args{include_dirs};
160  my @include_dirs = $self->arg_include_dirs(
161    @{ $include_dirs_ref || [] },
162    $self->perl_inc(),
163  );
164
165  my @defines = $self->arg_defines( %{$args{defines} || {}} );
166
167  my @extra_compiler_flags =
168    $self->split_like_shell($args{extra_compiler_flags});
169  my @cccdlflags = $self->split_like_shell($cf->{cccdlflags});
170  my @ccflags = $self->split_like_shell($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags});
171  my @optimize = $self->split_like_shell($cf->{optimize});
172  my @flags = (
173    @include_dirs,
174    @defines,
175    @cccdlflags,
176    @extra_compiler_flags,
177    $self->arg_nolink,
178    @ccflags,
179    @optimize,
180    $self->arg_object_file($object_file),
181  );
182  my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc});
183
184  $self->do_system(@cc, @flags, $args{source})
185    or die "error building $object_file from '$args{source}'";
186
187  return $object_file;
188}
189
190sub have_compiler {
191  my ($self, $is_cplusplus) = @_;
192  my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc";
193  my $suffix = $is_cplusplus ? ".cc" : ".c";
194  return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag};
195
196  my $result;
197  my $attempts = 3;
198  # tmpdir has issues for some people so fall back to current dir
199
200  # don't clobber existing files (rare, but possible)
201  my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix );
202  binmode $FH;
203
204  if ( $is_cplusplus ) {
205    print $FH q<namespace Bogus { extern "C" int boot_compilet() { return 1; } };> . "\n";
206  }
207  else {
208    # Use extern "C" if "cc" was set to a C++ compiler.
209    print $FH <<EOF;
210#ifdef __cplusplus
211extern "C"
212#endif
213int boot_compilet(void) { return 1; }
214EOF
215  }
216  close $FH;
217
218  my ($obj_file, @lib_files);
219  eval {
220    local $^W = 0;
221    local $self->{quiet} = 1;
222    $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile);
223    @lib_files = $self->link(objects => $obj_file, module_name => 'compilet');
224  };
225  $result = $@ ? 0 : 1;
226
227  foreach (grep defined, $tmpfile, $obj_file, @lib_files) {
228    1 while unlink;
229  }
230
231  return $self->{$have_compiler_flag} = $result;
232}
233
234sub have_cplusplus {
235  push @_, 1;
236  goto &have_compiler;
237}
238
239sub lib_file {
240  my ($self, $dl_file, %args) = @_;
241  $dl_file =~ s/\.[^.]+$//;
242  $dl_file =~ tr/"//d;
243
244  if (defined $args{module_name} and length $args{module_name}) {
245    # Need to create with the same name as DynaLoader will load with.
246    require DynaLoader;
247    if (defined &DynaLoader::mod2fname) {
248      my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]);
249      my ($dev, $lib_dir, undef) = File::Spec->splitpath($dl_file);
250      $dl_file = File::Spec->catpath($dev, $lib_dir, $lib);
251    }
252  }
253
254  $dl_file .= ".$self->{config}{dlext}";
255
256  return $dl_file;
257}
258
259
260sub exe_file {
261  my ($self, $dl_file) = @_;
262  $dl_file =~ s/\.[^.]+$//;
263  $dl_file =~ tr/"//d;
264  return "$dl_file$self->{config}{_exe}";
265}
266
267sub need_prelink { 0 }
268
269sub extra_link_args_after_prelink { return }
270
271sub prelink {
272  my ($self, %args) = @_;
273
274  my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args);
275
276  require ExtUtils::Mksymlists;
277  # dl. abbrev for dynamic library
278  ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } );
279
280  # Mksymlists will create one of these files
281  return grep -e, map "$dl_file_out.$_", qw(ext def opt);
282}
283
284sub _prepare_mksymlists_args {
285  my $args = shift;
286  ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file};
287
288  my %mksymlists_args = (
289    DL_VARS  => $args->{dl_vars}      || [],
290    DL_FUNCS => $args->{dl_funcs}     || {},
291    FUNCLIST => $args->{dl_func_list} || [],
292    IMPORTS  => $args->{dl_imports}   || {},
293    NAME     => $args->{dl_name},    # Name of the Perl module
294    DLBASE   => $args->{dl_base},    # Basename of DLL file
295    FILE     => $args->{dl_file},    # Dir + Basename of symlist file
296    VERSION  => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'),
297  );
298  return ($args->{dl_file}, \%mksymlists_args);
299}
300
301sub link {
302  my ($self, %args) = @_;
303  return $self->_do_link('lib_file', lddl => 1, %args);
304}
305
306sub link_executable {
307  my ($self, %args) = @_;
308  return $self->_do_link('exe_file', lddl => 0, %args);
309}
310
311sub _do_link {
312  my ($self, $type, %args) = @_;
313
314  my $cf = $self->{config}; # For convenience
315
316  my $objects = delete $args{objects};
317  $objects = [$objects] unless ref $objects;
318  my $out = $args{$type} || $self->$type($objects->[0], %args);
319
320  my @temp_files;
321  @temp_files =
322    $self->prelink(%args, dl_name => $args{module_name})
323      if $args{lddl} && $self->need_prelink;
324
325  my @linker_flags = (
326    $self->split_like_shell($args{extra_linker_flags}),
327    $self->extra_link_args_after_prelink(
328       %args, dl_name => $args{module_name}, prelink_res => \@temp_files
329    )
330  );
331
332  my @output = $args{lddl}
333    ? $self->arg_share_object_file($out)
334    : $self->arg_exec_file($out);
335  my @shrp = $self->split_like_shell($cf->{shrpenv});
336  my @ld = $self->split_like_shell($cf->{ld});
337
338  $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags)
339    or die "error building $out from @$objects";
340
341  return wantarray ? ($out, @temp_files) : $out;
342}
343
344sub quote_literal {
345  my ($self, $string) = @_;
346
347  if (length $string && $string !~ /[^a-zA-Z0-9,._+@%\/-]/) {
348    return $string;
349  }
350
351  $string =~ s{'}{'\\''}g;
352
353  return "'$string'";
354}
355
356sub do_system {
357  my ($self, @cmd) = @_;
358  if (!$self->{quiet}) {
359    my $full = join ' ', map $self->quote_literal($_), @cmd;
360    print $full . "\n";
361  }
362  return !system(@cmd);
363}
364
365sub split_like_shell {
366  my ($self, $string) = @_;
367
368  return () unless defined($string);
369  return @$string if UNIVERSAL::isa($string, 'ARRAY');
370  $string =~ s/^\s+|\s+$//g;
371  return () unless length($string);
372
373  # Text::ParseWords replaces all 'escaped' characters with themselves, which completely
374  # breaks paths under windows. As such, we forcibly replace backwards slashes with forward
375  # slashes on windows.
376  $string =~ s@\\@/@g if $^O eq 'MSWin32';
377
378  return Text::ParseWords::shellwords($string);
379}
380
381# if building perl, perl's main source directory
382sub perl_src {
383  # N.B. makemaker actually searches regardless of PERL_CORE, but
384  # only squawks at not finding it if PERL_CORE is set
385
386  return unless $ENV{PERL_CORE};
387
388  my $Updir = File::Spec->updir;
389  my $dir   = File::Spec->curdir;
390
391  # Try up to 5 levels upwards
392  for (0..10) {
393    if (
394      -f File::Spec->catfile($dir,"config_h.SH")
395      &&
396      -f File::Spec->catfile($dir,"perl.h")
397      &&
398      -f File::Spec->catfile($dir,"lib","Exporter.pm")
399    ) {
400      return Cwd::realpath( $dir );
401    }
402
403    $dir = File::Spec->catdir($dir, $Updir);
404  }
405
406  warn "PERL_CORE is set but I can't find your perl source!\n";
407  return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ???
408}
409
410# directory of perl's include files
411sub perl_inc {
412  my $self = shift;
413
414  $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE");
415}
416
417sub DESTROY {
418  my $self = shift;
419  local($., $@, $!, $^E, $?);
420  $self->cleanup();
421}
422
4231;
424
425# vim: ts=2 sw=2 et:
426