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.280231'; # 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 "class Bogus { public: int boot_compilet() { return 1; } };\n";
206  }
207  else {
208    print $FH "int boot_compilet() { return 1; }\n";
209  }
210  close $FH;
211
212  my ($obj_file, @lib_files);
213  eval {
214    local $^W = 0;
215    local $self->{quiet} = 1;
216    $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile);
217    @lib_files = $self->link(objects => $obj_file, module_name => 'compilet');
218  };
219  $result = $@ ? 0 : 1;
220
221  foreach (grep defined, $tmpfile, $obj_file, @lib_files) {
222    1 while unlink;
223  }
224
225  return $self->{$have_compiler_flag} = $result;
226}
227
228sub have_cplusplus {
229  push @_, 1;
230  goto &have_compiler;
231}
232
233sub lib_file {
234  my ($self, $dl_file, %args) = @_;
235  $dl_file =~ s/\.[^.]+$//;
236  $dl_file =~ tr/"//d;
237
238  if (defined $args{module_name} and length $args{module_name}) {
239    # Need to create with the same name as DynaLoader will load with.
240    require DynaLoader;
241    if (defined &DynaLoader::mod2fname) {
242      my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]);
243      my ($dev, $lib_dir, undef) = File::Spec->splitpath($dl_file);
244      $dl_file = File::Spec->catpath($dev, $lib_dir, $lib);
245    }
246  }
247
248  $dl_file .= ".$self->{config}{dlext}";
249
250  return $dl_file;
251}
252
253
254sub exe_file {
255  my ($self, $dl_file) = @_;
256  $dl_file =~ s/\.[^.]+$//;
257  $dl_file =~ tr/"//d;
258  return "$dl_file$self->{config}{_exe}";
259}
260
261sub need_prelink { 0 }
262
263sub extra_link_args_after_prelink { return }
264
265sub prelink {
266  my ($self, %args) = @_;
267
268  my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args);
269
270  require ExtUtils::Mksymlists;
271  # dl. abbrev for dynamic library
272  ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } );
273
274  # Mksymlists will create one of these files
275  return grep -e, map "$dl_file_out.$_", qw(ext def opt);
276}
277
278sub _prepare_mksymlists_args {
279  my $args = shift;
280  ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file};
281
282  my %mksymlists_args = (
283    DL_VARS  => $args->{dl_vars}      || [],
284    DL_FUNCS => $args->{dl_funcs}     || {},
285    FUNCLIST => $args->{dl_func_list} || [],
286    IMPORTS  => $args->{dl_imports}   || {},
287    NAME     => $args->{dl_name},    # Name of the Perl module
288    DLBASE   => $args->{dl_base},    # Basename of DLL file
289    FILE     => $args->{dl_file},    # Dir + Basename of symlist file
290    VERSION  => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'),
291  );
292  return ($args->{dl_file}, \%mksymlists_args);
293}
294
295sub link {
296  my ($self, %args) = @_;
297  return $self->_do_link('lib_file', lddl => 1, %args);
298}
299
300sub link_executable {
301  my ($self, %args) = @_;
302  return $self->_do_link('exe_file', lddl => 0, %args);
303}
304
305sub _do_link {
306  my ($self, $type, %args) = @_;
307
308  my $cf = $self->{config}; # For convenience
309
310  my $objects = delete $args{objects};
311  $objects = [$objects] unless ref $objects;
312  my $out = $args{$type} || $self->$type($objects->[0], %args);
313
314  my @temp_files;
315  @temp_files =
316    $self->prelink(%args, dl_name => $args{module_name})
317      if $args{lddl} && $self->need_prelink;
318
319  my @linker_flags = (
320    $self->split_like_shell($args{extra_linker_flags}),
321    $self->extra_link_args_after_prelink(
322       %args, dl_name => $args{module_name}, prelink_res => \@temp_files
323    )
324  );
325
326  my @output = $args{lddl}
327    ? $self->arg_share_object_file($out)
328    : $self->arg_exec_file($out);
329  my @shrp = $self->split_like_shell($cf->{shrpenv});
330  my @ld = $self->split_like_shell($cf->{ld});
331
332  $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags)
333    or die "error building $out from @$objects";
334
335  return wantarray ? ($out, @temp_files) : $out;
336}
337
338
339sub do_system {
340  my ($self, @cmd) = @_;
341  print "@cmd\n" if !$self->{quiet};
342  return !system(@cmd);
343}
344
345sub split_like_shell {
346  my ($self, $string) = @_;
347
348  return () unless defined($string);
349  return @$string if UNIVERSAL::isa($string, 'ARRAY');
350  $string =~ s/^\s+|\s+$//g;
351  return () unless length($string);
352
353  # Text::ParseWords replaces all 'escaped' characters with themselves, which completely
354  # breaks paths under windows. As such, we forcibly replace backwards slashes with forward
355  # slashes on windows.
356  $string =~ s@\\@/@g if $^O eq 'MSWin32';
357
358  return Text::ParseWords::shellwords($string);
359}
360
361# if building perl, perl's main source directory
362sub perl_src {
363  # N.B. makemaker actually searches regardless of PERL_CORE, but
364  # only squawks at not finding it if PERL_CORE is set
365
366  return unless $ENV{PERL_CORE};
367
368  my $Updir = File::Spec->updir;
369  my $dir   = File::Spec->curdir;
370
371  # Try up to 5 levels upwards
372  for (0..10) {
373    if (
374      -f File::Spec->catfile($dir,"config_h.SH")
375      &&
376      -f File::Spec->catfile($dir,"perl.h")
377      &&
378      -f File::Spec->catfile($dir,"lib","Exporter.pm")
379    ) {
380      return Cwd::realpath( $dir );
381    }
382
383    $dir = File::Spec->catdir($dir, $Updir);
384  }
385
386  warn "PERL_CORE is set but I can't find your perl source!\n";
387  return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ???
388}
389
390# directory of perl's include files
391sub perl_inc {
392  my $self = shift;
393
394  $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE");
395}
396
397sub DESTROY {
398  my $self = shift;
399  local($., $@, $!, $^E, $?);
400  $self->cleanup();
401}
402
4031;
404
405# vim: ts=2 sw=2 et:
406