base.pm

source of perl for linux application,

  my $self = shift;
  my $p = $self->{properties};
  return $p->{dist_name} if defined $p->{dist_name};
  
  die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
    unless $self->module_name;
  
  ($p->{dist_name} = $self->module_name) =~ s/::/-/g;
  
  return $p->{dist_name};
}

sub dist_version_from {
  my ($self) = @_;
  my $p = $self->{properties};
  if ($self->module_name) {
    $p->{dist_version_from} ||=
	join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm';
  }
  return $p->{dist_version_from} || undef;
}

sub dist_version {
  my ($self) = @_;
  my $p = $self->{properties};

  return $p->{dist_version} if defined $p->{dist_version};

  if ( my $dist_version_from = $self->dist_version_from ) {
    my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) );
    my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from )
      or die "Can't find file $version_from to determine version";
    $p->{dist_version} = $pm_info->version();
  }

  die ("Can't determine distribution version, must supply either 'dist_version',\n".
       "'dist_version_from', or 'module_name' parameter")
    unless defined $p->{dist_version};

  return $p->{dist_version};
}

sub dist_author   { shift->_pod_parse('author')   }
sub dist_abstract { shift->_pod_parse('abstract') }

sub _pod_parse {
  my ($self, $part) = @_;
  my $p = $self->{properties};
  my $member = "dist_$part";
  return $p->{$member} if defined $p->{$member};
  
  my $docfile = $self->_main_docfile
    or return;
  my $fh = IO::File->new($docfile)
    or return;
  
  require Module::Build::PodParser;
  my $parser = Module::Build::PodParser->new(fh => $fh);
  my $method = "get_$part";
  return $p->{$member} = $parser->$method();
}

sub version_from_file { # Method provided for backwards compatability
  return Module::Build::ModuleInfo->new_from_file($_[1])->version();
}

sub find_module_by_name { # Method provided for backwards compatability
  return Module::Build::ModuleInfo->find_module_by_name(@_[1,2]);
}

sub add_to_cleanup {
  my $self = shift;
  my %files = map {$self->localize_file_path($_), 1} @_;
  $self->{phash}{cleanup}->write(\%files);
}

sub cleanup {
  my $self = shift;
  my $all = $self->{phash}{cleanup}->read;
  return keys %$all;
}

sub config_file {
  my $self = shift;
  return unless -d $self->config_dir;
  return File::Spec->catfile($self->config_dir, @_);
}

sub read_config {
  my ($self) = @_;
  
  my $file = $self->config_file('build_params')
    or die "Can't find 'build_params' in " . $self->config_dir;
  my $fh = IO::File->new($file) or die "Can't read '$file': $!";
  my $ref = eval do {local $/; <$fh>};
  die if $@;
  my $c;
  ($self->{args}, $c, $self->{properties}) = @$ref;
  $self->{config} = Module::Build::Config->new(values => $c);
  close $fh;
}

sub has_config_data {
  my $self = shift;
  return scalar grep $self->{phash}{$_}->has_data(), qw(config_data features auto_features);
}

sub _write_data {
  my ($self, $filename, $data) = @_;
  
  my $file = $self->config_file($filename);
  my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
  unless (ref($data)) {  # e.g. magicnum
    print $fh $data;
    return;
  }

  print {$fh} Module::Build::Dumper->_data_dump($data);
}

sub write_config {
  my ($self) = @_;
  
  File::Path::mkpath($self->{properties}{config_dir});
  -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!";
  
  my @items = @{ $self->prereq_action_types };
  $self->_write_data('prereqs', { map { $_, $self->$_() } @items });
  $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]);

  # Set a new magic number and write it to a file
  $self->_write_data('magicnum', $self->magic_number(int rand 1_000_000));

  $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params);
}

sub check_autofeatures {
  my ($self) = @_;
  my $features = $self->auto_features;
  
  return unless %$features;

  $self->log_info("Checking features:\n");

  my $max_name_len;
  $max_name_len = ( length($_) > $max_name_len ) ?
                    length($_) : $max_name_len
    for keys %$features;

  while (my ($name, $info) = each %$features) {
    $self->log_info("  $name" . '.' x ($max_name_len - length($name) + 4));

    if ( my $failures = $self->prereq_failures($info) ) {
      my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
			   keys %$failures ) ? 1 : 0;
      $self->log_info( $disabled ? "disabled\n" : "enabled\n" );

      my $log_text;
      while (my ($type, $prereqs) = each %$failures) {
	while (my ($module, $status) = each %$prereqs) {
	  my $required =
	    ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
	  my $prefix = ($required) ? '-' : '*';
	  $log_text .= "    $prefix $status->{message}\n";
	}
      }
      $self->log_warn("$log_text") unless $self->quiet;
    } else {
      $self->log_info("enabled\n");
    }
  }

  $self->log_warn("\n");
}

sub prereq_failures {
  my ($self, $info) = @_;

  my @types = @{ $self->prereq_action_types };
  $info ||= {map {$_, $self->$_()} @types};

  my $out;

  foreach my $type (@types) {
    my $prereqs = $info->{$type};
    while ( my ($modname, $spec) = each %$prereqs ) {
      my $status = $self->check_installed_status($modname, $spec);

      if ($type =~ /^(?:\w+_)?conflicts$/) {
	next if !$status->{ok};
	$status->{conflicts} = delete $status->{need};
	$status->{message} = "$modname ($status->{have}) conflicts with this distribution";

      } elsif ($type =~ /^(?:\w+_)?recommends$/) {
	next if $status->{ok};
	$status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
			      ? "Optional prerequisite $modname is not installed"
			      : "$modname ($status->{have}) is installed, but we prefer to have $spec");
      } else {
	next if $status->{ok};
      }

      $out->{$type}{$modname} = $status;
    }
  }

  return $out;
}

# returns a hash of defined prerequisites; i.e. only prereq types with values
sub _enum_prereqs {
  my $self = shift;
  my %prereqs;
  foreach my $type ( @{ $self->prereq_action_types } ) {
    if ( $self->can( $type ) ) {
      my $prereq = $self->$type() || {};
      $prereqs{$type} = $prereq if %$prereq;
    }
  }
  return \%prereqs;
}

sub check_prereq {
  my $self = shift;

  # If we have XS files, make sure we can process them.
  my $xs_files = $self->find_xs_files;
  if (keys %$xs_files && !$self->_mb_feature('C_support')) {
    $self->log_warn("Warning: this distribution contains XS files, ".
		    "but Module::Build is not configured with C_support.  ".
		    "Please install ExtUtils::CBuilder to enable C_support.\n");
  }

  # Check to see if there are any prereqs to check
  my $info = $self->_enum_prereqs;
  return 1 unless $info;

  $self->log_info("Checking prerequisites...\n");

  my $failures = $self->prereq_failures($info);

  if ( $failures ) {

    while (my ($type, $prereqs) = each %$failures) {
      while (my ($module, $status) = each %$prereqs) {
	my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? '*' : '- ERROR:';
	$self->log_warn(" $prefix $status->{message}\n");
      }
    }

    $self->log_warn(<<EOF);

ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
of the modules indicated above before proceeding with this installation

EOF
    return 0;

  } else {

    $self->log_info("Looks good\n\n");
    return 1;

  }
}

sub perl_version {
  my ($self) = @_;
  # Check the current perl interpreter
  # It's much more convenient to use $] here than $^V, but 'man
  # perlvar' says I'm not supposed to.  Bloody tyrant.
  return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
}

sub perl_version_to_float {
  my ($self, $version) = @_;
  return $version if grep( /\./, $version ) < 2;
  $version =~ s/\./../;
  $version =~ s/\.(\d+)/sprintf '%03d', $1/eg;
  return $version;
}

sub _parse_conditions {
  my ($self, $spec) = @_;

  if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
    return (">= $spec");
  } else {
    return split /\s*,\s*/, $spec;
  }
}

sub check_installed_status {
  my ($self, $modname, $spec) = @_;
  my %status = (need => $spec);
  
  if ($modname eq 'perl') {
    $status{have} = $self->perl_version;
  
  } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) {
    # Don't try to load if it's already loaded
    
  } else {
    my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname );
    unless (defined( $pm_info )) {
      @status{ qw(have message) } = ('<none>', "$modname is not installed");
      return \%status;
    }
    
    $status{have} = $pm_info->version();
    if ($spec and !defined($status{have})) {
      @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname");
      return \%status;
    }
  }
  
  my @conditions = $self->_parse_conditions($spec);
  
  foreach (@conditions) {
    my ($op, $version) = /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x
      or die "Invalid prerequisite condition '$_' for $modname";
    
    $version = $self->perl_version_to_float($version)
      if $modname eq 'perl';
    
    next if $op eq '>=' and !$version;  # Module doesn't have to actually define a $VERSION
    
    unless ($self->compare_versions( $status{have}, $op, $version )) {
      $status{message} = "$modname ($status{have}) is installed, but we need version $op $version";
      return \%status;
    }
  }
  
  $status{ok} = 1;
  return \%status;
}

sub compare_versions {
  my $self = shift;
  my ($v1, $op, $v2) = @_;
  $v1 = Module::Build::Version->new($v1) 
    unless UNIVERSAL::isa($v1,'Module::Build::Version');

  my $eval_str = "\$v1 $op \$v2";
  my $result   = eval $eval_str;
  $self->log_warn("error comparing versions: '$eval_str' $@") if $@;

  return $result;
}

# I wish I could set $! to a string, but I can't, so I use $@
sub check_installed_version {
  my ($self, $modname, $spec) = @_;
  
  my $status = $self->check_installed_status($modname, $spec);
  
  if ($status->{ok}) {
    return $status->{have} if $status->{have} and $status->{have} ne '<none>';
    return '0 but true';
  }
  
  $@ = $status->{message};
  return 0;
}

sub make_executable {
  # Perl's chmod() is mapped to useful things on various non-Unix
  # platforms, so we use it in the base class even though it looks
  # Unixish.

  my $self = shift;
  foreach (@_) {
    my $current_mode = (stat $_)[2];
    chmod $current_mode | oct(111), $_;
  }
}

sub is_executable {
  # We assume this does the right thing on generic platforms, though
  # we do some other more specific stuff on Unixish platforms.
  my ($self, $file) = @_;
  return -x $file;
}

sub _startperl { shift()->config('startperl') }

# Return any directories in @INC which are not in the default @INC for
# this perl.  For example, stuff passed in with -I or loaded with "use lib".
sub _added_to_INC {
  my $self = shift;

  my %seen;
  $seen{$_}++ foreach $self->_default_INC;
  return grep !$seen{$_}++, @INC;
}

# Determine the default @INC for this Perl
{
  my @default_inc; # Memoize
  sub _default_INC {
    my $self = shift;
    return @default_inc if @default_inc;
    
    local $ENV{PERL5LIB};  # this is not considered part of the default.
    
    my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
    
    my @inc = $self->_backticks($perl, '-le', 'print for @INC');
    chomp @inc;
    
    return @default_inc = @inc;
  }
}

sub print_build_script {
  my ($self, $fh) = @_;
  
  my $build_package = $self->build_class;
  
  my $closedata="";

  my %q = map {$_, $self->$_()} qw(config_dir base_dir);

  my $case_tolerant = 0+(File::Spec->can('case_tolerant')
			 && File::Spec->case_tolerant);
  $q{base_dir} = uc $q{base_dir} if $case_tolerant;
  $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;

  $q{magic_numfile} = $self->config_file('magicnum');

  my @myINC = $self->_added_to_INC;
  for (@myINC, values %q) {
    $_ = File::Spec->canonpath( $_ );
    s/([\\\'])/\\$1/g;
  }

  my $quoted_INC = join ",\n", map "     '$_'", @myINC;
  my $shebang = $self->_startperl;
  my $magic_number = $self->magic_number;

  print $fh <<EOF;
$shebang

use strict;
use Cwd;
use File::Basename;
use File::Spec;

sub magic_number_matches {
  return 0 unless -e '$q{magic_numfile}';
  local *FH;
  open FH, '$q{magic_numfile}' or return 0;
  my \$filenum = <FH>;
  close FH;
  return \$filenum == $magic_number;
}

my \$progname;
my \$orig_dir;
BEGIN {
  \$^W = 1;  # Use warnings
  \$progname = basename(\$0);
  \$orig_dir = Cwd::cwd();
  my \$base_dir = '$q{base_dir}';
  if (!magic_number_matches()) {