base.pm

source of perl for linux application,

    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";
}

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 $failures = $self->prereq_failures($info);
      my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
			   keys %$failures ) ? 1 : 0;
      return !$disabled;
    }

    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;
  
  if (($self->module_name || '') eq 'Module::Build') {
    # We're building Module::Build itself, so ...::ConfigData isn't
    # valid, but $self->features() should be.
    return $self->feature(@_);
  } else {
    require Module::Build::ConfigData;
    return Module::Build::ConfigData->feature(@_);
  }
}


sub add_build_element {
    my ($self, $elem) = @_;
    my $elems = $self->build_elements;
    push @$elems, $elem unless grep { $_ eq $elem } @$elems;
}

sub ACTION_config_data {
  my $self = shift;
  return unless $self->has_config_data;
  
  my $module_name = $self->module_name
    or die "The config_data feature requires that 'module_name' be set";
  my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ???
  my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm");

  return if $self->up_to_date(['Build.PL',
			       $self->config_file('config_data'),
			       $self->config_file('features')
			      ], $notes_pm);

  $self->log_info("Writing config notes to $notes_pm\n");
  File::Path::mkpath(File::Basename::dirname($notes_pm));

  Module::Build::Notes->write_config_data
      (
       file => $notes_pm,
       module => $module_name,
       config_module => $notes_name,
       config_data => scalar $self->config_data,
       feature => scalar $self->{phash}{features}->access(),
       auto_features => scalar $self->auto_features,
      );
}

{
    my %valid_properties = ( __PACKAGE__,  {} );
    my %additive_properties;

    sub _mb_classes {
      my $class = ref($_[0]) || $_[0];
      return ($class, $class->mb_parents);
    }

    sub valid_property {
      my ($class, $prop) = @_;
      return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
    }

    sub valid_properties {
      return keys %{ shift->valid_properties_defaults() };
    }

    sub valid_properties_defaults {
      my %out;
      for (reverse shift->_mb_classes) {
	@out{ keys %{ $valid_properties{$_} } } = values %{ $valid_properties{$_} };
      }
      return \%out;
    }

    sub array_properties {
      for (shift->_mb_classes) {
        return @{$additive_properties{$_}->{ARRAY}}
	  if exists $additive_properties{$_}->{ARRAY};
      }
    }

    sub hash_properties {
      for (shift->_mb_classes) {
        return @{$additive_properties{$_}->{'HASH'}}
	  if exists $additive_properties{$_}->{'HASH'};
      }
    }

    sub add_property {
      my ($class, $property, $default) = @_;
      die "Property '$property' already exists" if $class->valid_property($property);

      $valid_properties{$class}{$property} = $default;

      my $type = ref $default;
      if ($type) {
	push @{$additive_properties{$class}->{$type}}, $property;
      }

      unless ($class->can($property)) {
        no strict 'refs';
	if ( $type eq 'HASH' ) {
          *{"$class\::$property"} = sub {
	    my $self = shift;
	    my $x = $self->{properties};
	    return $x->{$property} unless @_;

	    if ( defined($_[0]) && !ref($_[0]) ) {
	      if ( @_ == 1 ) {
		return exists( $x->{$property}{$_[0]} ) ?
		         $x->{$property}{$_[0]} : undef;
              } elsif ( @_ % 2 == 0 ) {
	        my %args = @_;
	        while ( my($k, $v) = each %args ) {
	          $x->{$property}{$k} = $v;
	        }
	      } else {
		die "Unexpected arguments for property '$property'\n";
	      }
	    } else {
	      $x->{$property} = $_[0];
	    }
	  };

        } else {
          *{"$class\::$property"} = sub {
	    my $self = shift;
	    $self->{properties}{$property} = shift if @_;
	    return $self->{properties}{$property};
	  }
        }

      }
      return $class;
    }

    sub _set_defaults {
      my $self = shift;

      # Set the build class.
      $self->{properties}{build_class} ||= ref $self;

      # If there was no orig_dir, set to the same as base_dir
      $self->{properties}{orig_dir} ||= $self->{properties}{base_dir};

      my $defaults = $self->valid_properties_defaults;
      
      foreach my $prop (keys %$defaults) {
	$self->{properties}{$prop} = $defaults->{$prop}
	  unless exists $self->{properties}{$prop};
      }
      
      # Copy defaults for arrays any arrays.
      for my $prop ($self->array_properties) {
	$self->{properties}{$prop} = [@{$defaults->{$prop}}]
	  unless exists $self->{properties}{$prop};
      }
      # Copy defaults for arrays any hashes.
      for my $prop ($self->hash_properties) {
	$self->{properties}{$prop} = {%{$defaults->{$prop}}}
	  unless exists $self->{properties}{$prop};
      }
    }

}

# Add the default properties.
__PACKAGE__->add_property(blib => 'blib');
__PACKAGE__->add_property(build_class => 'Module::Build');
__PACKAGE__->add_property(build_elements => [qw(PL support pm xs pod script)]);
__PACKAGE__->add_property(build_script => 'Build');
__PACKAGE__->add_property(build_bat => 0);
__PACKAGE__->add_property(config_dir => '_build');
__PACKAGE__->add_property(include_dirs => []);
__PACKAGE__->add_property(installdirs => 'site');
__PACKAGE__->add_property(metafile => 'META.yml');
__PACKAGE__->add_property(recurse_into => []);
__PACKAGE__->add_property(use_rcfile => 1);
__PACKAGE__->add_property(create_packlist => 1);
__PACKAGE__->add_property(allow_mb_mismatch => 0);
__PACKAGE__->add_property(config => undef);

{
  my $Is_ActivePerl = eval {require ActivePerl::DocTools};
  __PACKAGE__->add_property(html_css => $Is_ActivePerl ? 'Active.css' : '');
}

{
  my @prereq_action_types = qw(requires build_requires conflicts recommends);
  foreach my $type (@prereq_action_types) {
    __PACKAGE__->add_property($type => {});
  }
  __PACKAGE__->add_property(prereq_action_types => \@prereq_action_types);
}

__PACKAGE__->add_property($_ => {}) for qw(
  get_options
  install_base_relpaths
  install_path
  install_sets
  meta_add
  meta_merge
  original_prefix
  prefix_relpaths
  configure_requires
);

__PACKAGE__->add_property($_) for qw(
  PL_files
  autosplit
  base_dir
  bindoc_dirs
  c_source
  create_makefile_pl
  create_readme
  debugger
  destdir
  dist_abstract
  dist_author
  dist_name
  dist_version
  dist_version_from
  extra_compiler_flags
  extra_linker_flags
  has_config_data
  install_base
  libdoc_dirs
  license
  magic_number
  mb_version
  module_name
  orig_dir
  perl
  pm_files
  pod_files
  pollute
  prefix
  quiet
  recursive_test_files
  script_files
  scripts
  test_files
  verbose
  xs_files
);

sub config {
  my $self = shift;
  my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
  return $c->all_config unless @_;

  my $key = shift;
  return $c->get($key) unless @_;

  my $val = shift;
  return $c->set($key => $val);
}

sub mb_parents {
    # Code borrowed from Class::ISA.
    my @in_stack = (shift);
    my %seen = ($in_stack[0] => 1);

    my ($current, @out);
    while (@in_stack) {
        next unless defined($current = shift @in_stack)
          && $current->isa('Module::Build::Base');
        push @out, $current;
        next if $current eq 'Module::Build::Base';
        no strict 'refs';
        unshift @in_stack,
          map {
              my $c = $_; # copy, to avoid being destructive
              substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
              # Canonize the :: -> main::, ::foo -> main::foo thing.
              # Should I ever canonize the Foo'Bar = Foo::Bar thing?
              $seen{$c}++ ? () : $c;
          } @{"$current\::ISA"};

        # I.e., if this class has any parents (at least, ones I've never seen
        # before), push them, in order, onto the stack of classes I need to
        # explore.
    }
    shift @out;
    return @out;
}

sub extra_linker_flags   { shift->_list_accessor('extra_linker_flags',   @_) }
sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }

sub _list_accessor {
  (my $self, local $_) = (shift, shift);
  my $p = $self->{properties};
  $p->{$_} = [@_] if @_;
  $p->{$_} = [] unless exists $p->{$_};
  return ref($p->{$_}) ? $p->{$_} : [$p->{$_}];
}

# XXX Problem - if Module::Build is loaded from a different directory,
# it'll look for (and perhaps destroy/create) a _build directory.
sub subclass {
  my ($pack, %opts) = @_;

  my $build_dir = '_build'; # XXX The _build directory is ostensibly settable by the user.  Shouldn't hard-code here.
  $pack->delete_filetree($build_dir) if -e $build_dir;

  die "Must provide 'code' or 'class' option to subclass()\n"
    unless $opts{code} or $opts{class};

  $opts{code}  ||= '';
  $opts{class} ||= 'MyModuleBuilder';
  
  my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm';
  my $filedir  = File::Basename::dirname($filename);
  $pack->log_info("Creating custom builder $filename in $filedir\n");
  
  File::Path::mkpath($filedir);
  die "Can't create directory $filedir: $!" unless -d $filedir;
  
  my $fh = IO::File->new("> $filename") or die "Can't create $filename: $!";
  print $fh <<EOF;
package $opts{class};
use $pack;
\@ISA = qw($pack);
$opts{code}
1;
EOF
  close $fh;
  
  unshift @INC, File::Spec->catdir(File::Spec->rel2abs($build_dir), 'lib');
  eval "use $opts{class}";
  die $@ if $@;

  return $opts{class};
}

sub dist_name {