Alien-ROOT

 view release on metacpan or  search on metacpan

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

}

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 => {},
      stash => {}, # temporary caching, not stored in _build
  }, $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 from shell strings to arrays
  for ('extra_compiler_flags', 'extra_linker_flags') {
    $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
  }

  # Convert to arrays
  for ('include_dirs') {
    $p->{$_} = [ $p->{$_} ] if exists $p->{$_} && !ref $p->{$_}
  }

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

  return $self;
}

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

sub log_info {
  my $self = shift;
  print @_ if ref($self) && ( $self->verbose || ! $self->quiet );
}
sub log_verbose {
  my $self = shift;
  print @_ if ref($self) && $self->verbose;
}
sub log_debug {
  my $self = shift;
  print @_ if ref($self) && $self->debug;
}

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 @_;
  }
}


# install paths must be generated when requested to be sure all changes
# to config (from various sources) are included
sub _default_install_paths {
  my $self = shift;
  my $c = $self->{config};
  my $p = {};

  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} =

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

__PACKAGE__->add_property(test_file_exts => ['.t']);
__PACKAGE__->add_property(use_tap_harness => 0);
__PACKAGE__->add_property(cpan_client => 'cpan');
__PACKAGE__->add_property(tap_harness_args => {});
__PACKAGE__->add_property(
  'installdirs',
  default => 'site',
  check   => sub {
    return 1 if /^(core|site|vendor)$/;
    return shift->property_error(
      $_ eq 'perl'
      ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
      : 'installdirs must be one of "core", "site", or "vendor"'
    );
    return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
    return 0;
  },
);

{
  __PACKAGE__->add_property(html_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_license
  create_makefile_pl
  create_readme
  debugger
  destdir
  dist_abstract
  dist_author
  dist_name
  dist_suffix
  dist_version
  dist_version_from
  extra_compiler_flags
  extra_linker_flags
  has_config_data
  install_base
  libdoc_dirs
  magic_number
  mb_version
  module_name
  needs_compiler
  orig_dir
  perl
  pm_files
  pod_files
  pollute
  prefix
  program_name
  quiet
  recursive_test_files
  release_status
  script_files
  scripts
  share_dir
  sign
  test_files
  verbose
  debug
  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_verbose("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 _guess_module_name {
  my $self = shift;
  my $p = $self->{properties};
  return if $p->{module_name};
  if ( $p->{dist_version_from} && -e $p->{dist_version_from} ) {
    my $mi = Module::Build::ModuleInfo->new_from_file($self->dist_version_from);
    $p->{module_name} = $mi->name;
  }
  else {
    my $mod_path = my $mod_name = $p->{dist_name};
    $mod_name =~ s{-}{::}g;
    $mod_path =~ s{-}{/}g;
    $mod_path .= ".pm";

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

    # XXX Should we let Getopt::Long handle M::B's options? That would
    # be easy-ish to add to @specs right here, but wouldn't handle options
    # passed without "--" as M::B currently allows. We might be able to
    # get around this by setting the "prefix_pattern" Configure option.
    my @specs;
    my $args = {};
    # Construct the specifications for GetOptions.
    while (my ($k, $v) = each %$specs) {
        # Throw an error if specs conflict with our own.
        die "Option specification '$k' conflicts with a " . ref $self
          . " option of the same name"
          if $self->valid_property($k);
        push @specs, $k . (defined $v->{type} ? $v->{type} : '');
        push @specs, $v->{store} if exists $v->{store};
        $args->{$k} = $v->{default} if exists $v->{default};
    }

    local @ARGV = @argv; # No other way to dupe Getopt::Long

    # Get the options values and return them.
    # XXX Add option to allow users to set options?
    if ( @specs ) {
      Getopt::Long::Configure('pass_through');
      Getopt::Long::GetOptions($args, @specs);
    }

    return $args, @ARGV;
}

sub unparse_args {
  my ($self, $args) = @_;
  my @out;
  while (my ($k, $v) = each %$args) {
    push @out, (UNIVERSAL::isa($v, 'HASH')  ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
                UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
                ("--$k", $v));
  }
  return @out;
}

sub args {
    my $self = shift;
    return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
    my $key = shift;
    $self->{args}{$key} = shift if @_;
    return $self->{args}{$key};
}

# allows select parameters (with underscores) to be spoken with dashes
# when used as command-line options
sub _translate_option {
  my $self = shift;
  my $opt  = shift;

  (my $tr_opt = $opt) =~ tr/-/_/;

  return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
    create_license
    create_makefile_pl
    create_readme
    extra_compiler_flags
    extra_linker_flags
    install_base
    install_path
    meta_add
    meta_merge
    test_files
    use_rcfile
    use_tap_harness
    tap_harness_args
    cpan_client
  ); # normalize only selected option names

  return $opt;
}

my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdir verbose quiet uninst debug sign/;

sub _read_arg {
  my ($self, $args, $key, $val) = @_;

  $key = $self->_translate_option($key);

  if ( exists $args->{$key} and not $singular_argument{$key} ) {
    $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
    push @{$args->{$key}}, $val;
  } else {
    $args->{$key} = $val;
  }
}

# decide whether or not an option requires/has an operand
sub _optional_arg {
  my $self = shift;
  my $opt  = shift;
  my $argv = shift;

  $opt = $self->_translate_option($opt);

  my @bool_opts = qw(
    build_bat
    create_license
    create_readme
    pollute
    quiet
    uninst
    use_rcfile
    verbose
    debug
    sign
    use_tap_harness
  );

  # inverted boolean options; eg --noverbose or --no-verbose
  # converted to proper name & returned with false value (verbose, 0)
  if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
    $opt =~ s/^no-?//;
    return ($opt, 0);
  }

  # non-boolean option; return option unchanged along with its argument
  return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;

  # we're punting a bit here, if an option appears followed by a digit
  # we take the digit as the argument for the option. If there is
  # nothing that looks like a digit, we pretend the option is a flag
  # that is being set and has no argument.
  my $arg = 1;
  $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;

  return ($opt, $arg);
}

sub read_args {
  my $self = shift;

  (my $args, @_) = $self->cull_options(@_);
  my %args = %$args;

  my $opt_re = qr/[\w\-]+/;

  my ($action, @argv);
  while (@_) {
    local $_ = shift;
    if ( /^(?:--)?($opt_re)=(.*)$/ ) {
      $self->_read_arg(\%args, $1, $2);
    } elsif ( /^--($opt_re)$/ ) {
      my($opt, $arg) = $self->_optional_arg($1, \@_);
      $self->_read_arg(\%args, $opt, $arg);
    } elsif ( /^($opt_re)$/ and !defined($action)) {
      $action = $1;
    } else {
      push @argv, $_;
    }
  }
  $args{ARGV} = \@argv;

  for ('extra_compiler_flags', 'extra_linker_flags') {
    $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
  }

  # Convert to arrays
  for ('include_dirs') {
    $args{$_} = [ $args{$_} ] if exists $args{$_} && !ref $args{$_}
  }

  # Hashify these parameters
  for ($self->hash_properties, 'config') {
    next unless exists $args{$_};
    my %hash;
    $args{$_} ||= [];
    $args{$_} = [ $args{$_} ] unless ref $args{$_};
    foreach my $arg ( @{$args{$_}} ) {
      $arg =~ /($opt_re)=(.*)/
        or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'";
      $hash{$1} = $2;
    }
    $args{$_} = \%hash;
  }

  # De-tilde-ify any path parameters
  for my $key (qw(prefix install_base destdir)) {
    next if !defined $args{$key};
    $args{$key} = $self->_detildefy($args{$key});
  }

  for my $key (qw(install_path)) {
    next if !defined $args{$key};

    for my $subkey (keys %{$args{$key}}) {
      next if !defined $args{$key}{$subkey};
      my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
      if ( $subkey eq 'html' ) { # translate for compatibility
        $args{$key}{binhtml} = $subkey_ext;
        $args{$key}{libhtml} = $subkey_ext;
      } else {
        $args{$key}{$subkey} = $subkey_ext;
      }
    }
  }

  if ($args{makefile_env_macros}) {
    require Module::Build::Compat;
    %args = (%args, Module::Build::Compat->makefile_to_build_macros);
  }

  return \%args, $action;
}

# Default: do nothing.  Overridden for Unix & Windows.
sub _detildefy {}


# merge Module::Build argument lists that have already been parsed
# by read_args(). Takes two references to option hashes and merges
# the contents, giving priority to the first.
sub _merge_arglist {
  my( $self, $opts1, $opts2 ) = @_;

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

    $fh->close;
    if (!$self->_is_ActivePerl) {
      # These fixups are already done by AP::DT:P:pod2html
      # The output from pod2html is NOT XHTML!
      # IE6+ will display content that is not valid for DOCTYPE
      $html =~ s#^<!DOCTYPE .*?>#<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">#im;
      $html =~ s#<html xmlns="http://www.w3.org/1999/xhtml">#<html>#i;

      # IE6+ will not display local HTML files with strict
      # security without this comment
      $html =~ s#<head>#<head>\n<!-- saved from url=(0017)http://localhost/ -->#i;
    }
    # Fixup links that point to our temp blib
    $html =~ s/\Q$blibdir\E//g;

    $fh = IO::File->new(">$outfile") or die "Can't write $outfile: $!";
    print $fh $html;
    $fh->close;
    unlink($tmpfile);
  }

  return ! $errors;

}

# Adapted from ExtUtils::MM_Unix
sub man1page_name {
  my $self = shift;
  return File::Basename::basename( shift );
}

# Adapted from ExtUtils::MM_Unix and Pod::Man
# Depending on M::B's dependency policy, it might make more sense to refactor
# Pod::Man::begin_pod() to extract a name() methods, and use them...
#    -spurkis
sub man3page_name {
  my $self = shift;
  my ($vol, $dirs, $file) = File::Spec->splitpath( shift );
  my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );

  # Remove known exts from the base name
  $file =~ s/\.p(?:od|m|l)\z//i;

  return join( $self->manpage_separator, @dirs, $file );
}

sub manpage_separator {
  return '::';
}

# For systems that don't have 'diff' executable, should use Algorithm::Diff
sub ACTION_diff {
  my $self = shift;
  $self->depends_on('build');
  my $local_lib = File::Spec->rel2abs('lib');
  my @myINC = grep {$_ ne $local_lib} @INC;

  # The actual install destination might not be in @INC, so check there too.
  push @myINC, map $self->install_destination($_), qw(lib arch);

  my @flags = @{$self->{args}{ARGV}};
  @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;

  my $installmap = $self->install_map;
  delete $installmap->{read};
  delete $installmap->{write};

  my $text_suffix = $self->file_qr('\.(pm|pod)$');

  while (my $localdir = each %$installmap) {
    my @localparts = File::Spec->splitdir($localdir);
    my $files = $self->rscan_dir($localdir, sub {-f});

    foreach my $file (@$files) {
      my @parts = File::Spec->splitdir($file);
      @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar

      my $installed = Module::Build::ModuleInfo->find_module_by_name(
                        join('::', @parts), \@myINC );
      if (not $installed) {
        print "Only in lib: $file\n";
        next;
      }

      my $status = File::Compare::compare($installed, $file);
      next if $status == 0;  # Files are the same
      die "Can't compare $installed and $file: $!" if $status == -1;

      if ($file =~ $text_suffix) {
        $self->do_system('diff', @flags, $installed, $file);
      } else {
        print "Binary files $file and $installed differ\n";
      }
    }
  }
}

sub ACTION_pure_install {
  shift()->depends_on('install');
}

sub ACTION_install {
  my ($self) = @_;
  require ExtUtils::Install;
  $self->depends_on('build');
  # RT#63003 suggest that odd cirmstances that we might wind up
  # in a different directory than we started, so wrap with _do_in_dir to
  # ensure we get back to where we started; hope this fixes it!
  $self->_do_in_dir( ".", sub {
    ExtUtils::Install::install(
      $self->install_map, $self->verbose, 0, $self->{args}{uninst}||0
    );
  });
  if ($self->_is_ActivePerl && $self->{_completed_actions}{html}) {
    $self->log_info("Building ActivePerl Table of Contents\n");
    eval { ActivePerl::DocTools::WriteTOC(verbose => $self->verbose ? 1 : 0); 1; }
      or $self->log_warn("AP::DT:: WriteTOC() failed: $@");
  }
  if ($self->_is_ActivePPM) {
    # We touch 'lib/perllocal.pod'. There is an existing logic in subroutine _init_db()
    # of 'ActivePerl/PPM/InstallArea.pm' that says that if 'lib/perllocal.pod' has a 'date-last-touched'
    # greater than that of the PPM SQLite databases ('etc/ppm-perl-area.db' and/or
    # 'site/etc/ppm-site-area.db') then the PPM SQLite databases are rebuilt from scratch.

    # in the following line, 'perllocal.pod' this is *always* 'lib/perllocal.pod', never 'site/lib/perllocal.pod'
    my $F_perllocal = File::Spec->catfile($self->install_sets('core', 'lib'), 'perllocal.pod');
    my $dt_stamp = time;

    $self->log_info("For ActivePerl's PPM: touch '$F_perllocal'\n");

    open my $perllocal, ">>", $F_perllocal;
    close $perllocal;
    utime($dt_stamp, $dt_stamp, $F_perllocal);
  }
}

sub ACTION_fakeinstall {
  my ($self) = @_;
  require ExtUtils::Install;
  my $eui_version = ExtUtils::Install->VERSION;
  if ( $eui_version < 1.32 ) {
    $self->log_warn(
      "The 'fakeinstall' action requires Extutils::Install 1.32 or later.\n"
      . "(You only have version $eui_version)."
    );
    return;
  }
  $self->depends_on('build');
  ExtUtils::Install::install($self->install_map, !$self->quiet, 1, $self->{args}{uninst}||0);
}

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

  # Normalize versions or delete them if undef/0
  for my $provides ( values %prime ) {
    if ( $provides->{version} ) {
      $provides->{version} = $self->normalize_version( $provides->{version} )
    }
    else {
      delete $provides->{version};
    }
  }

  return \%prime;
}

# separate out some of the conflict resolution logic from
# $self->find_dist_packages(), above, into a helper function.
#
sub _resolve_module_versions {
  my $self = shift;

  my $packages = shift;

  my( $file, $version );
  my $err = '';
    foreach my $p ( @$packages ) {
      if ( defined( $p->{version} ) ) {
        if ( defined( $version ) ) {
          if ( $self->compare_versions( $version, '!=', $p->{version} ) ) {
            $err .= "  $p->{file} ($p->{version})\n";
          } else {
            # same version declared multiple times, ignore
          }
        } else {
          $file    = $p->{file};
          $version = $p->{version};
        }
      }
      $file ||= $p->{file} if defined( $p->{file} );
    }

  if ( $err ) {
    $err = "  $file ($version)\n" . $err;
  }

  my %result = (
    file    => $file,
    version => $version,
    err     => $err
  );

  return \%result;
}

sub make_tarball {
  my ($self, $dir, $file) = @_;
  $file ||= $dir;

  $self->log_info("Creating $file.tar.gz\n");

  if ($self->{args}{tar}) {
    my $tar_flags = $self->verbose ? 'cvf' : 'cf';
    $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir);
    $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip};
  } else {
    eval { require Archive::Tar && Archive::Tar->VERSION(1.09); 1 }
      or die "You must install Archive::Tar 1.09+ to make a distribution tarball\n".
             "or specify a binary tar program with the '--tar' option.\n".
             "See the documentation for the 'dist' action.\n";

    my $files = $self->rscan_dir($dir);

    # Archive::Tar versions >= 1.09 use the following to enable a compatibility
    # hack so that the resulting archive is compatible with older clients.
    # If no file path is 100 chars or longer, we disable the prefix field
    # for maximum compatibility.  If there are any long file paths then we
    # need the prefix field after all.
    $Archive::Tar::DO_NOT_USE_PREFIX =
      (grep { length($_) >= 100 } @$files) ? 0 : 1;

    my $tar   = Archive::Tar->new;
    $tar->add_files(@$files);
    for my $f ($tar->get_files) {
      $f->mode($f->mode & ~022); # chmod go-w
    }
    $tar->write("$file.tar.gz", 1);
  }
}

sub install_path {
  my $self = shift;
  my( $type, $value ) = ( @_, '<empty>' );

  Carp::croak( 'Type argument missing' )
    unless defined( $type );

  my $map = $self->{properties}{install_path};
  return $map unless @_;

  # delete existing value if $value is literal undef()
  unless ( defined( $value ) ) {
    delete( $map->{$type} );
    return undef;
  }

  # return existing value if no new $value is given
  if ( $value eq '<empty>' ) {
    return undef unless exists $map->{$type};
    return $map->{$type};
  }

  # set value if $value is a valid relative path
  return $map->{$type} = $value;
}

sub install_sets {
  # Usage: install_sets('site'), install_sets('site', 'lib'),
  #   or install_sets('site', 'lib' => $value);
  my ($self, $dirs, $key, $value) = @_;
  $dirs = $self->installdirs unless defined $dirs;
  # update property before merging with defaults
  if ( @_ == 4 && defined $dirs && defined $key) {
    # $value can be undef; will mask default

inc/inc_Module-Build/Module/Build/Base.pm  view on Meta::CPAN

  foreach (@_) {
    next unless -e $_;
    $self->log_verbose("Deleting $_\n");
    File::Path::rmtree($_, 0, 0);
    die "Couldn't remove '$_': $!\n" if -e $_;
    $deleted++;
  }
  return $deleted;
}

sub autosplit_file {
  my ($self, $file, $to) = @_;
  require AutoSplit;
  my $dir = File::Spec->catdir($to, 'lib', 'auto');
  AutoSplit::autosplit($file, $dir);
}

sub cbuilder {
  # Returns a CBuilder object

  my $self = shift;
  my $s = $self->{stash};
  return $s->{_cbuilder} if $s->{_cbuilder};

  require ExtUtils::CBuilder;
  return $s->{_cbuilder} = ExtUtils::CBuilder->new(
    config => $self->config,
    ($self->quiet ? (quiet => 1 ) : ()),
  );
}

sub have_c_compiler {
  my ($self) = @_;

  my $p = $self->{properties};
  return $p->{_have_c_compiler} if defined $p->{_have_c_compiler};

  $self->log_verbose("Checking if compiler tools configured... ");
  my $b = eval { $self->cbuilder };
  my $have = $b && eval { $b->have_compiler };
  $self->log_verbose($have ? "ok.\n" : "failed.\n");
  return $p->{_have_c_compiler} = $have;
}

sub compile_c {
  my ($self, $file, %args) = @_;

  if ( ! $self->have_c_compiler ) {
    die "Error: no compiler detected to compile '$file'.  Aborting\n";
  }

  my $b = $self->cbuilder;
  my $obj_file = $b->object_file($file);
  $self->add_to_cleanup($obj_file);
  return $obj_file if $self->up_to_date($file, $obj_file);

  $b->compile(source => $file,
              defines => $args{defines},
              object_file => $obj_file,
              include_dirs => $self->include_dirs,
              extra_compiler_flags => $self->extra_compiler_flags,
             );

  return $obj_file;
}

sub link_c {
  my ($self, $spec) = @_;
  my $p = $self->{properties}; # For convenience

  $self->add_to_cleanup($spec->{lib_file});

  my $objects = $p->{objects} || [];

  return $spec->{lib_file}
    if $self->up_to_date([$spec->{obj_file}, @$objects],
                         $spec->{lib_file});

  my $module_name = $spec->{module_name} || $self->module_name;

  $self->cbuilder->link(
    module_name => $module_name,
    objects     => [$spec->{obj_file}, @$objects],
    lib_file    => $spec->{lib_file},
    extra_linker_flags => $p->{extra_linker_flags} );

  return $spec->{lib_file};
}

sub compile_xs {
  my ($self, $file, %args) = @_;

  $self->log_verbose("$file -> $args{outfile}\n");

  if (eval {require ExtUtils::ParseXS; 1}) {

    ExtUtils::ParseXS::process_file(
                                    filename => $file,
                                    prototypes => 0,
                                    output => $args{outfile},
                                   );
  } else {
    # Ok, I give up.  Just use backticks.

    my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp')
      or die "Can't find ExtUtils::xsubpp in INC (@INC)";

    my @typemaps;
    push @typemaps, Module::Build::ModuleInfo->find_module_by_name(
        'ExtUtils::typemap', \@INC
    );
    my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name(
        'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')]
    );
    push @typemaps, $lib_typemap if $lib_typemap;
    @typemaps = map {+'-typemap', $_} @typemaps;

    my $cf = $self->{config};
    my $perl = $self->{properties}{perl};

    my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
                   @typemaps, $file);

    $self->log_info("@command\n");
    my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!";
    print {$fh} $self->_backticks(@command);
    close $fh;
  }
}

sub split_like_shell {
  my ($self, $string) = @_;

  return () unless defined($string);
  return @$string if UNIVERSAL::isa($string, 'ARRAY');
  $string =~ s/^\s+|\s+$//g;
  return () unless length($string);

  return Text::ParseWords::shellwords($string);
}

sub oneliner {
  # Returns a string that the shell can evaluate as a perl command.
  # This should be avoided whenever possible, since "the shell" really
  # means zillions of shells on zillions of platforms and it's really