[Summary view] [Print] [Text view]

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