view release on metacpan or  search on metacpan

local/lib/perl5/Module/Build/Base.pm  view on Meta::CPAN

  foreach my $thisperl ( @potential_perls ) {

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

    if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
      return $thisperl;
    }
  }

  # We've tried all alternatives, and didn't find a perl that matches
  # our configuration. Throw an exception, and list alternatives we tried.
  my @paths = map File::Basename::dirname($_), @potential_perls;
  die "Can't locate the perl binary used to run this script " .
      "in (@paths)\n";
}

# Adapted from IPC::Cmd::can_run()
sub find_command {
  my ($self, $command) = @_;

  if( File::Spec->file_name_is_absolute($command) ) {
    return $self->_maybe_command($command);

  } else {
    for my $dir ( File::Spec->path ) {
      my $abs = File::Spec->catfile($dir, $command);
      return $abs if $abs = $self->_maybe_command($abs);
    }
  }
}

# Copied from ExtUtils::MM_Unix::maybe_command
sub _maybe_command {
  my($self,$file) = @_;
  return $file if -x $file && ! -d $file;
  return;
}

sub _is_interactive {
  return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;   # Pipe?
}

# NOTE this is a blocking operation if(-t STDIN)
sub _is_unattended {
  my $self = shift;
  return $ENV{PERL_MM_USE_DEFAULT} ||
    ( !$self->_is_interactive && eof STDIN );
}

sub _readline {
  my $self = shift;
  return undef if $self->_is_unattended;

  my $answer = <STDIN>;
  chomp $answer if defined $answer;
  return $answer;
}

sub prompt {
  my $self = shift;
  my $mess = shift
    or die "prompt() called without a prompt message";

  # use a list to distinguish a default of undef() from no default
  my @def;
  @def = (shift) if @_;
  # use dispdef for output
  my @dispdef = scalar(@def) ?
    ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
    (' ', '');

  local $|=1;
  print "$mess ", @dispdef;

  if ( $self->_is_unattended && !@def ) {
    die <<EOF;
ERROR: This build seems to be unattended, but there is no default value
for this question.  Aborting.
EOF
  }

  my $ans = $self->_readline();

  if ( !defined($ans)        # Ctrl-D or unattended
       or !length($ans) ) {  # User hit return
    print "$dispdef[1]\n";
    $ans = scalar(@def) ? $def[0] : '';
  }

  return $ans;
}

sub y_n {
  my $self = shift;
  my ($mess, $def)  = @_;

  die "y_n() called without a prompt message" unless $mess;
  die "Invalid default value: y_n() default must be 'y' or 'n'"
    if $def && $def !~ /^[yn]/i;

  my $answer;
  while (1) { # XXX Infinite or a large number followed by an exception ?
    $answer = $self->prompt(@_);
    return 1 if $answer =~ /^y/i;
    return 0 if $answer =~ /^n/i;
    local $|=1;
    print "Please answer 'y' or 'n'.\n";
  }
}

sub current_action { shift->{action} }
sub invoked_action { shift->{invoked_action} }

sub notes        { shift()->{phash}{notes}->access(@_) }
sub config_data  { shift()->{phash}{config_data}->access(@_) }
sub runtime_params { shift->{phash}{runtime_params}->read( @_ ? shift : () ) }  # Read-only
sub auto_features  { shift()->{phash}{auto_features}->access(@_) }

sub features     {
  my $self = shift;
  my $ph = $self->{phash};

  if (@_) {
    my $key = shift;
    if ($ph->{features}->exists($key)) {
      return $ph->{features}->access($key, @_);
    }

    if (my $info = $ph->{auto_features}->access($key)) {
      my $disabled;
      for my $type ( @{$self->prereq_action_types} ) {
        next if $type eq 'description' || $type eq 'recommends' || ! exists $info->{$type};
        my $prereqs = $info->{$type};
        for my $modname ( sort keys %$prereqs ) {
          my $spec = $prereqs->{$modname};
          my $status = $self->check_installed_status($modname, $spec);
          if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
          if ( ! eval "require $modname; 1" ) { return 0; }
        }
      }
      return 1;
    }

    return $ph->{features}->access($key, @_);
  }

  # No args - get the auto_features & overlay the regular features
  my %features;
  my %auto_features = $ph->{auto_features}->access();
  while (my ($name, $info) = each %auto_features) {
    my $failures = $self->prereq_failures($info);
    my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
                        keys %$failures ) ? 1 : 0;
    $features{$name} = $disabled ? 0 : 1;
  }
  %features = (%features, $ph->{features}->access());

  return wantarray ? %features : \%features;
}
BEGIN { *feature = \&features } # Alias

sub _mb_feature {
  my $self = shift;