lib/ExtUtils/CBuilder/Base.pm

   1 package ExtUtils::CBuilder::Base;
   2
   3 use strict;
   4 use File::Spec;
   5 use File::Basename;
   6 use Config;
   7 use Text::ParseWords;
   8
   9 use vars qw($VERSION);
  10 $VERSION = '0.12';
  11
  12 sub new {
  13   my $class = shift;
  14   my $self = bless {@_}, $class;
  15
  16   $self->{properties}{perl} = $class->find_perl_interpreter
  17     or warn "Warning: Can't locate your perl binary";
  18
  19   while (my ($k,$v) = each %Config) {
  20     $self->{config}{$k} = $v unless exists $self->{config}{$k};
  21   }
  22   return $self;
  23 }
  24
  25 sub find_perl_interpreter {
  26   my $perl;
  27   File::Spec->file_name_is_absolute($perl = $^X)
  28     or -f ($perl = $Config::Config{perlpath})
  29     or ($perl = $^X);
  30   return $perl;
  31 }
  32
  33 sub add_to_cleanup {
  34   my $self = shift;
  35   foreach (@_) {
  36     $self->{files_to_clean}{$_} = 1;
  37   }
  38 }
  39
  40 sub cleanup {
  41   my $self = shift;
  42   foreach my $file (keys %{$self->{files_to_clean}}) {
  43     unlink $file;
  44   }
  45 }
  46
  47 sub object_file {
  48   my ($self, $filename) = @_;
  49
  50   # File name, minus the suffix
  51   (my $file_base = $filename) =~ s/\.[^.]+$//;
  52   return "$file_base$self->{config}{obj_ext}";
  53 }
  54
  55 sub arg_include_dirs {
  56   my $self = shift;
  57   return map {"-I$_"} @_;
  58 }
  59
  60 sub arg_nolink { '-c' }
  61
  62 sub arg_object_file {
  63   my ($self, $file) = @_;
  64   return ('-o', $file);
  65 }
  66
  67 sub arg_share_object_file {
  68   my ($self, $file) = @_;
  69   return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file);
  70 }
  71
  72 sub arg_exec_file {
  73   my ($self, $file) = @_;
  74   return ('-o', $file);
  75 }
  76
  77 sub compile {
  78   my ($self, %args) = @_;
  79   die "Missing 'source' argument to compile()" unless defined $args{source};
  80
  81   my $cf = $self->{config}; # For convenience
  82
  83   $args{object_file} ||= $self->object_file($args{source});
  84
  85   my @include_dirs = $self->arg_include_dirs
  86     (@{$args{include_dirs} || []},
  87      $self->perl_inc());
  88
  89   my @extra_compiler_flags = $self->split_like_shell($args{extra_compiler_flags});
  90   my @cccdlflags = $self->split_like_shell($cf->{cccdlflags});
  91   my @ccflags = $self->split_like_shell($cf->{ccflags});
  92
  93   #VMS can only have one include list, remove the one from config.
  94   if ((@include_dirs != 0) && ($^O eq 'VMS')) {
  95     for (@ccflags) {
  96       s/\/Include[^\/]*//;
  97     }
  98   }
  99   my @optimize = $self->split_like_shell($cf->{optimize});
 100   my @flags = (@include_dirs, @cccdlflags, @extra_compiler_flags,
 101                $self->arg_nolink,
 102                @ccflags, @optimize,
 103                $self->arg_object_file($args{object_file}),
 104               );
 105
 106   my @cc = $self->split_like_shell($cf->{cc});
 107
 108   $self->do_system(@cc, @flags, $args{source})
 109     or die "error building $args{object_file} from '$args{source}'";
 110
 111   return $args{object_file};
 112 }
 113
 114 sub have_compiler {
 115   my ($self) = @_;
 116   return $self->{have_compiler} if defined $self->{have_compiler};
 117
 118   my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, 'compilet.c');
 119   {
 120     local *FH;
 121     open FH, "> $tmpfile" or die "Can't create $tmpfile: $!";
 122     print FH "int boot_compilet() { return 1; }\n";
 123     close FH;
 124   }
 125
 126   my ($obj_file, @lib_files);
 127   eval {
 128     $obj_file = $self->compile(source => $tmpfile);
 129     @lib_files = $self->link(objects => $obj_file, module_name => 'compilet');
 130   };
 131   warn $@ if $@;
 132   my $result = $self->{have_compiler} = $@ ? 0 : 1;
 133
 134   foreach (grep defined, $tmpfile, $obj_file, @lib_files) {
 135     1 while unlink;
 136   }
 137   return $result;
 138 }
 139
 140 sub lib_file {
 141   my ($self, $dl_file) = @_;
 142   $dl_file =~ s/\.[^.]+$//;
 143   $dl_file =~ tr/"//d;
 144   return "$dl_file.$self->{config}{dlext}";
 145 }
 146
 147
 148 sub exe_file {
 149   my ($self, $dl_file) = @_;
 150   $dl_file =~ s/\.[^.]+$//;
 151   $dl_file =~ tr/"//d;
 152   return "$dl_file$self->{config}{_exe}";
 153 }
 154
 155 sub need_prelink { 0 }
 156
 157 sub prelink {
 158   my ($self, %args) = @_;
 159
 160   ($args{dl_file} = $args{dl_name}) =~ s/.*::// unless $args{dl_file};
 161
 162   require ExtUtils::Mksymlists;
 163   ExtUtils::Mksymlists::Mksymlists( # dl. abbrev for dynamic library
 164     DL_VARS  => $args{dl_vars}      || [],
 165     DL_FUNCS => $args{dl_funcs}     || {},
 166     FUNCLIST => $args{dl_func_list} || [],
 167     IMPORTS  => $args{dl_imports}   || {},
 168     NAME     => $args{dl_name},
 169     DLBASE   => $args{dl_base},
 170     FILE     => $args{dl_file},
 171   );
 172
 173   # Mksymlists will create one of these files
 174   return grep -e, map "$args{dl_file}.$_", qw(ext def opt);
 175 }
 176
 177 sub link {
 178   my ($self, %args) = @_;
 179   return $self->_do_link('lib_file', lddl => 1, %args);
 180 }
 181
 182 sub link_executable {
 183   my ($self, %args) = @_;
 184   return $self->_do_link('exe_file', lddl => 0, %args);
 185 }
 186
 187 sub _do_link {
 188   my ($self, $type, %args) = @_;
 189
 190   my $cf = $self->{config}; # For convenience
 191
 192   my $objects = delete $args{objects};
 193   $objects = [$objects] unless ref $objects;
 194   my $out = $args{$type} || $self->$type($objects->[0]);
 195
 196   # Need to create with the same name as Dyanloader will load with.
 197   if ($^O eq 'VMS') {
 198     my ($dev,$dir,$file) = File::Spec->splitpath($out);
 199     if (defined &DynaLoader::mod2fname) {
 200       $file = DynaLoader::mod2fname([$file]);
 201       $out = File::Spec->catpath($dev,$dir,$file);
 202     }
 203   }
 204
 205   my @temp_files;
 206   @temp_files =
 207     $self->prelink(%args,
 208                    dl_name => $args{module_name}) if $args{lddl} && $self->need_prelink;
 209
 210   my @linker_flags = $self->split_like_shell($args{extra_linker_flags});
 211   my @output = $args{lddl} ? $self->arg_share_object_file($out) : $self->arg_exec_file($out);
 212   my @shrp = $self->split_like_shell($cf->{shrpenv});
 213   my @ld = $self->split_like_shell($cf->{ld});
 214
 215   # vms has two option files, the external symbol, and to pull in PerlShr
 216   if ($^O eq 'VMS') {
 217     $objects->[0] .= ',';
 218     $objects->[1] = 'sys$disk:[]' . @temp_files[0] . '/opt,';
 219     $objects->[2] = $self->perl_inc() . 'PerlShr.Opt/opt';
 220   }
 221
 222   $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags)
 223     or die "error building $out from @$objects";
 224
 225   return wantarray ? ($out, @temp_files) : $out;
 226 }
 227
 228
 229 sub do_system {
 230   my ($self, @cmd) = @_;
 231   print "@cmd\n" if !$self->{quiet};
 232   return !system(@cmd);
 233 }
 234
 235 sub split_like_shell {
 236   my ($self, $string) = @_;
 237
 238   return () unless defined($string);
 239   return @$string if UNIVERSAL::isa($string, 'ARRAY');
 240   $string =~ s/^\s+|\s+$//g;
 241   return () unless length($string);
 242
 243   return Text::ParseWords::shellwords($string);
 244 }
 245
 246 # if building perl, perl's main source directory
 247 sub perl_src {
 248   # N.B. makemaker actually searches regardless of PERL_CORE, but
 249   # only squawks at not finding it if PERL_CORE is set
 250
 251   return unless $ENV{PERL_CORE};
 252
 253   my $Updir  = File::Spec->updir;
 254   my $dir = $Updir;
 255
 256   # Try up to 5 levels upwards
 257   for (1..5) {
 258     if (
 259         -f File::Spec->catfile($dir,"config_h.SH")
 260         &&
 261         -f File::Spec->catfile($dir,"perl.h")
 262         &&
 263         -f File::Spec->catfile($dir,"lib","Exporter.pm")
 264        ) {
 265       return $dir;
 266     }
 267
 268     $dir = File::Spec->catdir($dir, $Updir);
 269   }
 270
 271   warn "PERL_CORE is set but I can't find your perl source!\n";
 272   return;
 273 }
 274
 275 # directory of perl's include files
 276 sub perl_inc {
 277   my $self = shift;
 278
 279   $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE");
 280 }
 281
 282 sub DESTROY {
 283   my $self = shift;
 284   $self->cleanup();
 285 }
 286
 287 1;