local-lib5/lib/perl5/ExtUtils/CBuilder/Base.pm

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