base.pm

source of perl for linux application,

package Module::Build::Base;

use strict;
use vars qw($VERSION);
$VERSION = '0.2808_01';
$VERSION = eval $VERSION;
BEGIN { require 5.00503 }

use Carp;
use File::Copy ();
use File::Find ();
use File::Path ();
use File::Basename ();
use File::Spec 0.82 ();
use File::Compare ();
use Module::Build::Dumper ();
use IO::File ();
use Text::ParseWords ();

use Module::Build::ModuleInfo;
use Module::Build::Notes;
use Module::Build::Config;


#################### Constructors ###########################
sub new {
  my $self = shift()->_construct(@_);

  $self->{invoked_action} = $self->{action} ||= 'Build_PL';
  $self->cull_args(@ARGV);
  
  die "Too early to specify a build action '$self->{action}'.  Do 'Build $self->{action}' instead.\n"
    if $self->{action} && $self->{action} ne 'Build_PL';

  $self->check_manifest;
  $self->check_prereq;
  $self->check_autofeatures;

  $self->dist_name;
  $self->dist_version;

  $self->_set_install_paths;
  $self->_find_nested_builds;

  return $self;
}

sub resume {
  my $package = shift;
  my $self = $package->_construct(@_);
  $self->read_config;

  # If someone called Module::Build->current() or
  # Module::Build->new_from_context() and the correct class to use is
  # actually a *subclass* of Module::Build, we may need to load that
  # subclass here and re-delegate the resume() method to it.
  unless ( UNIVERSAL::isa($package, $self->build_class) ) {
    my $build_class = $self->build_class;
    my $config_dir = $self->config_dir || '_build';
    my $build_lib = File::Spec->catdir( $config_dir, 'lib' );
    unshift( @INC, $build_lib );
    unless ( $build_class->can('new') ) {
      eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@";
    }
    return $build_class->resume(@_);
  }

  unless ($self->_perl_is_same($self->{properties}{perl})) {
    my $perl = $self->find_perl_interpreter;
    $self->log_warn(" * WARNING: Configuration was initially created with '$self->{properties}{perl}',\n".
		    "   but we are now using '$perl'.\n");
  }
  
  $self->cull_args(@ARGV);

  unless ($self->allow_mb_mismatch) {
    my $mb_version = $Module::Build::VERSION;
    die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n".
	"   but we are now using version '$mb_version'.  Please re-run the Build.PL or Makefile.PL script,\n".
	"   or use --allow_mb_mismatch 1 to skip this version check.\n")
    if $mb_version ne $self->{properties}{mb_version};
  }
  
  $self->{invoked_action} = $self->{action} ||= 'build';
  
  return $self;
}

sub new_from_context {
  my ($package, %args) = @_;
  
  # XXX Read the META.yml and see whether we need to run the Build.PL?
  
  # Run the Build.PL.  We use do() rather than run_perl_script() so
  # that it runs in this process rather than a subprocess, because we
  # need to make sure that the environment is the same during Build.PL
  # as it is during resume() (and thereafter).
  {
    local @ARGV = $package->unparse_args(\%args);
    do './Build.PL';
    die $@ if $@;
  }
  return $package->resume;
}

sub current {
  # hmm, wonder what the right thing to do here is
  local @ARGV;
  return shift()->resume;
}

sub _construct {
  my ($package, %input) = @_;

  my $args   = delete $input{args}   || {};
  my $config = delete $input{config} || {};

  my $self = bless {
		    args => {%$args},
		    config => Module::Build::Config->new(values => $config),
		    properties => {
				   base_dir        => $package->cwd,
				   mb_version      => $Module::Build::VERSION,
				   %input,
				  },
		    phash => {},
		   }, $package;

  $self->_set_defaults;
  my ($p, $ph) = ($self->{properties}, $self->{phash});

  foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
    my $file = File::Spec->catfile($self->config_dir, $_);
    $ph->{$_} = Module::Build::Notes->new(file => $file);
    $ph->{$_}->restore if -e $file;
    if (exists $p->{$_}) {
      my $vals = delete $p->{$_};
      while (my ($k, $v) = each %$vals) {
	$self->$_($k, $v);
      }
    }
  }

  # The following warning could be unnecessary if the user is running
  # an embedded perl, but there aren't too many of those around, and
  # embedded perls aren't usually used to install modules, and the
  # installation process sometimes needs to run external scripts
  # (e.g. to run tests).
  $p->{perl} = $self->find_perl_interpreter
    or $self->log_warn("Warning: Can't locate your perl binary");

  my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
  $p->{bindoc_dirs} ||= [ $blibdir->("script") ];
  $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];

  $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};

  # Synonyms
  $p->{requires} = delete $p->{prereq} if defined $p->{prereq};
  $p->{script_files} = delete $p->{scripts} if defined $p->{scripts};

  # Convert to arrays
  for ('extra_compiler_flags', 'extra_linker_flags') {
    $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
  }

  $self->add_to_cleanup( @{delete $p->{add_to_cleanup}} )
    if $p->{add_to_cleanup};

  return $self;
}

################## End constructors #########################

sub log_info { print @_ unless shift()->quiet }
sub log_verbose { shift()->log_info(@_) if $_[0]->verbose }
sub log_warn {
  # Try to make our call stack invisible
  shift;
  if (@_ and $_[-1] !~ /\n$/) {
    my (undef, $file, $line) = caller();
    warn @_, " at $file line $line.\n";
  } else {
    warn @_;
  }
}


sub _set_install_paths {
  my $self = shift;
  my $c = $self->{config};
  my $p = $self->{properties};

  my @libstyle = $c->get('installstyle') ?
      File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
  my $arch     = $c->get('archname');
  my $version  = $c->get('version');

  my $bindoc  = $c->get('installman1dir') || undef;
  my $libdoc  = $c->get('installman3dir') || undef;

  my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef;
  my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef;

  $p->{install_sets} =
    {
     core   => {
		lib     => $c->get('installprivlib'),
		arch    => $c->get('installarchlib'),
		bin     => $c->get('installbin'),
		script  => $c->get('installscript'),
		bindoc  => $bindoc,
		libdoc  => $libdoc,
		binhtml => $binhtml,
		libhtml => $libhtml,
	       },
     site   => {
		lib     => $c->get('installsitelib'),
		arch    => $c->get('installsitearch'),
		bin     => $c->get('installsitebin') || $c->get('installbin'),
		script  => $c->get('installsitescript') ||
		           $c->get('installsitebin') || $c->get('installscript'),
		bindoc  => $c->get('installsiteman1dir') || $bindoc,
		libdoc  => $c->get('installsiteman3dir') || $libdoc,
		binhtml => $c->get('installsitehtml1dir') || $binhtml,
		libhtml => $c->get('installsitehtml3dir') || $libhtml,
	       },
     vendor => {
		lib     => $c->get('installvendorlib'),
		arch    => $c->get('installvendorarch'),
		bin     => $c->get('installvendorbin') || $c->get('installbin'),
		script  => $c->get('installvendorscript') ||
		           $c->get('installvendorbin') || $c->get('installscript'),
		bindoc  => $c->get('installvendorman1dir') || $bindoc,
		libdoc  => $c->get('installvendorman3dir') || $libdoc,
		binhtml => $c->get('installvendorhtml1dir') || $binhtml,
		libhtml => $c->get('installvendorhtml3dir') || $libhtml,
	       },
    };

  $p->{original_prefix} =
    {
     core   => $c->get('installprefixexp') || $c->get('installprefix') ||
               $c->get('prefixexp')        || $c->get('prefix') || '',
     site   => $c->get('siteprefixexp'),
     vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
    };
  $p->{original_prefix}{site} ||= $p->{original_prefix}{core};

  # Note: you might be tempted to use $Config{installstyle} here
  # instead of hard-coding lib/perl5, but that's been considered and
  # (at least for now) rejected.  `perldoc Config` has some wisdom
  # about it.
  $p->{install_base_relpaths} =
    {
     lib     => ['lib', 'perl5'],
     arch    => ['lib', 'perl5', $arch],
     bin     => ['bin'],
     script  => ['bin'],
     bindoc  => ['man', 'man1'],
     libdoc  => ['man', 'man3'],
     binhtml => ['html'],
     libhtml => ['html'],
    };

  $p->{prefix_relpaths} =
    {
     core => {
	      lib        => [@libstyle],
	      arch       => [@libstyle, $version, $arch],
	      bin        => ['bin'],
	      script     => ['bin'],
	      bindoc     => ['man', 'man1'],
	      libdoc     => ['man', 'man3'],
	      binhtml    => ['html'],
	      libhtml    => ['html'],
	     },
     vendor => {
		lib        => [@libstyle],
		arch       => [@libstyle, $version, $arch],
		bin        => ['bin'],
		script     => ['bin'],
		bindoc     => ['man', 'man1'],
		libdoc     => ['man', 'man3'],
		binhtml    => ['html'],
		libhtml    => ['html'],
	       },
     site => {
	      lib        => [@libstyle, 'site_perl'],
	      arch       => [@libstyle, 'site_perl', $version, $arch],
	      bin        => ['bin'],
	      script     => ['bin'],
	      bindoc     => ['man', 'man1'],
	      libdoc     => ['man', 'man3'],
	      binhtml    => ['html'],
	      libhtml    => ['html'],
	     },
    };

}

sub _find_nested_builds {
  my $self = shift;
  my $r = $self->recurse_into or return;

  my ($file, @r);
  if (!ref($r) && $r eq 'auto') {
    local *DH;
    opendir DH, $self->base_dir
      or die "Can't scan directory " . $self->base_dir . " for nested builds: $!";
    while (defined($file = readdir DH)) {
      my $subdir = File::Spec->catdir( $self->base_dir, $file );
      next unless -d $subdir;
      push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' );
    }
  }

  $self->recurse_into(\@r);
}

sub cwd {
  require Cwd;
  return Cwd::cwd();
}

sub _quote_args {
  # Returns a string that can become [part of] a command line with
  # proper quoting so that the subprocess sees this same list of args.
  my ($self, @args) = @_;

  my $return_args = '';
  my @quoted;

  for (@args) {
    if ( /^[^\s*?!$<>;\\|'"\[\]\{\}]+$/ ) {
      # Looks pretty safe
      push @quoted, $_;
    } else {
      # XXX this will obviously have to improve - is there already a
      # core module lying around that does proper quoting?
      s/"/"'"'"/g;
      push @quoted, qq("$_");
    }
  }

  return join " ", @quoted;
}

sub _backticks {
  my ($self, @cmd) = @_;
  if ($self->have_forkpipe) {
    local *FH;
    my $pid = open *FH, "-|";
    if ($pid) {
      return wantarray ? <FH> : join '', <FH>;
    } else {
      die "Can't execute @cmd: $!\n" unless defined $pid;
      exec { $cmd[0] } @cmd;
    }
  } else {
    my $cmd = $self->_quote_args(@cmd);
    return `$cmd`;
  }
}

sub have_forkpipe { 1 }

# Determine whether a given binary is the same as the perl
# (configuration) that started this process.
sub _perl_is_same {
  my ($self, $perl) = @_;

  my @cmd = ($perl);

  # When run from the perl core, @INC will include the directories
  # where perl is yet to be installed. We need to reference the
  # absolute path within the source distribution where it can find
  # it's Config.pm This also prevents us from picking up a Config.pm
  # from a different configuration that happens to be already
  # installed in @INC.
  if ($ENV{PERL_CORE}) {
    push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
  }

  push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
  return $self->_backticks(@cmd) eq Config->myconfig;
}

# cache _discover_perl_interpreter() results
{
  my $known_perl;
  sub find_perl_interpreter {
    my $self = shift;

    return $known_perl if defined($known_perl);
    return $known_perl = $self->_discover_perl_interpreter;
  }
}

# Returns the absolute path of the perl interperter used to invoke
# this process. The path is derived from $^X or $Config{perlpath}. On
# some platforms $^X contains the complete absolute path of the
# interpreter, on other it may contain a relative path, or simply
# 'perl'. This can also vary depending on whether a path was supplied
# when perl was invoked. Additionally, the value in $^X may omit the
# executable extension on platforms that use one. It's a fatal error
# if the interpreter can't be found because it can result in undefined
# behavior by routines that depend on it (generating errors or
# invoking the wrong perl.)
sub _discover_perl_interpreter {
  my $proto = shift;
  my $c     = ref($proto) ? $proto->{config} : 'Module::Build::Config';

  my $perl  = $^X;
  my $perl_basename = File::Basename::basename($perl);

  my @potential_perls;

  # Try 1, Check $^X for absolute path
  push( @potential_perls, $perl )
      if File::Spec->file_name_is_absolute($perl);

  # Try 2, Check $^X for a valid relative path
  my $abs_perl = File::Spec->rel2abs($perl);
  push( @potential_perls, $abs_perl );

  # Try 3, Last ditch effort: These two option use hackery to try to locate
  # a suitable perl. The hack varies depending on whether we are running
  # from an installed perl or an uninstalled perl in the perl source dist.
  if ($ENV{PERL_CORE}) {

    # Try 3.A, If we are in a perl source tree, running an uninstalled
    # perl, we can keep moving up the directory tree until we find our
    # binary. We wouldn't do this under any other circumstances.

    # CBuilder is also in the core, so it should be available here
    require ExtUtils::CBuilder;
    my $perl_src = ExtUtils::CBuilder->perl_src;
    if ( defined($perl_src) && length($perl_src) ) {
      my $uninstperl =
        File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
      push( @potential_perls, $uninstperl );
    }

  } else {

    # Try 3.B, First look in $Config{perlpath}, then search the user's
    # PATH. We do not want to do either if we are running from an
    # uninstalled perl in a perl source tree.

    push( @potential_perls, $c->get('perlpath') );

    push( @potential_perls,
          map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
  }

  # Now that we've enumerated the potential perls, it's time to test
  # them to see if any of them match our configuration, returning the
  # absolute path of the first successful match.
  my $exe = $c->get('exe_ext');
  foreach my $thisperl ( @potential_perls ) {

    if (defined $exe) {
      $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
    }