Acme-Sort-Sleep

 view release on metacpan or  search on metacpan

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

    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 {
  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 @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/('+)/'"$1"'/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`;
  }
}

# Tells us whether the construct open($fh, '-|', @command) is
# supported.  It would probably be better to dynamically sense this.
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 interpreter 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.

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

    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 = version->new($v1)
    unless eval { $v1->isa('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 $config_requires;
  if ( -f $self->metafile ) {
    my $meta = eval { $self->read_metafile( $self->metafile ) };
    $config_requires = $meta && $meta->{prereqs}{configure}{requires}{'Module::Build'};
  }
  $config_requires ||= 0;

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

  $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( $_ ) unless $self->is_vmsish;
    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}';
  my \$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()) {
    unless (chdir(\$base_dir)) {
      die ("Couldn't chdir(\$base_dir), aborting\\n");
    }
    unless (magic_number_matches()) {
      die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
    }
  }
  unshift \@INC,
    (
$quoted_INC
    );
}

close(*DATA) unless eof(*DATA); # ensure no open handles to this script

use $build_package;
Module::Build->VERSION(q{$config_requires});

# Some platforms have problems setting \$^X in shebang contexts, fix it up here
\$^X = Module::Build->find_perl_interpreter;

if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
   warn "Warning: Build.PL has been altered.  You may need to run 'perl Build.PL' again.\\n";
}

# This should have just enough arguments to be able to bootstrap the rest.
my \$build = $build_package->resume (
  properties => {
    config_dir => '$q{config_dir}',
    orig_dir => \$orig_dir,
  },
);

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

    local $Test::Harness::verbose = $self->verbose || 0;
    local $Test::Harness::switches = join ' ', $self->harness_switches;

    Test::Harness::runtests(@$tests);
}

sub run_visual_script {
    my $self = shift;
    # This will get run and the user will see the output.  It doesn't
    # emit Test::Harness-style output.
    $self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
        if -e 'visual.pl';
}

sub harness_switches {
    my $self = shift;
    my @res;
    push @res, qw(-w -d) if $self->{properties}{debugger};
    push @res, '-MDevel::Cover' if $self->{properties}{cover};
    return @res;
}

sub test_files {
  my $self = shift;
  my $p = $self->{properties};
  if (@_) {
    return $p->{test_files} = (@_ == 1 ? shift : [@_]);
  }
  return $self->find_test_files;
}

sub expand_test_dir {
  my ($self, $dir) = @_;
  my $exts = $self->{properties}{test_file_exts};

  return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
    if $self->recursive_test_files;

  return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
}

sub ACTION_testdb {
  my ($self) = @_;
  local $self->{properties}{debugger} = 1;
  $self->depends_on('test');
}

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

  unless (Module::Metadata->find_module_by_name('Devel::Cover')) {
    warn("Cannot run testcover action unless Devel::Cover is installed.\n");
    return;
  }

  $self->add_to_cleanup('coverage', 'cover_db');
  $self->depends_on('code');

  # See whether any of the *.pm files have changed since last time
  # testcover was run.  If so, start over.
  if (-e 'cover_db') {
    my $pm_files = $self->rscan_dir
        (File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') );
    my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});

    $self->do_system(qw(cover -delete))
      unless $self->up_to_date($pm_files,         $cover_files)
          && $self->up_to_date($self->test_files, $cover_files);
  }

  local $self->{properties}{cover} = 1;
  $self->depends_on('test');
  $self->do_system('cover');
}

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

  # All installable stuff gets created in blib/ .
  # Create blib/arch to keep blib.pm happy
  my $blib = $self->blib;
  $self->add_to_cleanup($blib);
  File::Path::mkpath( File::Spec->catdir($blib, 'arch') );

  if (my $split = $self->autosplit) {
    $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
  }

  foreach my $element (@{$self->build_elements}) {
    my $method = "process_${element}_files";
    $method = "process_files_by_extension" unless $self->can($method);
    $self->$method($element);
  }

  $self->depends_on('config_data');
}

sub ACTION_build {
  my $self = shift;
  $self->log_info("Building " . $self->dist_name . "\n");
  $self->depends_on('code');
  $self->depends_on('docs');
}

sub process_files_by_extension {
  my ($self, $ext) = @_;

  my $method = "find_${ext}_files";
  my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext,  'lib');

  foreach my $file (sort keys %$files) {
    $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $files->{$file}) );
  }
}

sub process_support_files {
  my $self = shift;
  my $p = $self->{properties};
  return unless $p->{c_source};

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

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)$');

  foreach my $localdir (sort keys %$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::Metadata->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 circumstances 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);
}

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

  die "You must have only.pm 0.25 or greater installed for this operation: $@\n"
    unless eval { require only; 'only'->VERSION(0.25); 1 };

  $self->depends_on('build');

  my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()}
    qw(version versionlib);
  only::install::install(%onlyargs);
}

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

  # XXX include feature prerequisites as optional prereqs?

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

  # we can't check it, just add it anyway to be safe
  for my $file ( $self->mymetafile, $self->mymetafile2 ) {
    unless ( $skip_factory && $skip_factory->($maniskip)->($file) ) {
      $self->log_warn("File '$maniskip' does not include '$file'. Adding it now.\n");
      my $safe = quotemeta($file);
      $self->_append_maniskip("^$safe\$", $maniskip);
    }
  }
}

sub _add_to_manifest {
  my ($self, $manifest, $lines) = @_;
  $lines = [$lines] unless ref $lines;

  my $existing_files = $self->_read_manifest($manifest);
  return unless defined( $existing_files );

  @$lines = grep {!exists $existing_files->{$_}} @$lines
    or return;

  my $mode = (stat $manifest)[2];
  chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";

  open(my $fh, '<', $manifest) or die "Can't read $manifest: $!";
  my $last_line = (<$fh>)[-1] || "\n";
  my $has_newline = $last_line =~ /\n$/;
  close $fh;

  open($fh, '>>', $manifest) or die "Can't write to $manifest: $!";
  print $fh "\n" unless $has_newline;
  print $fh map "$_\n", @$lines;
  close $fh;
  chmod($mode, $manifest);

  $self->log_verbose(map "Added to $manifest: $_\n", @$lines);
}

sub _sign_dir {
  my ($self, $dir) = @_;

  unless (eval { require Module::Signature; 1 }) {
    $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n");
    return;
  }

  # Add SIGNATURE to the MANIFEST
  {
    my $manifest = File::Spec->catfile($dir, 'MANIFEST');
    die "Signing a distribution requires a MANIFEST file" unless -e $manifest;
    $self->_add_to_manifest($manifest, "SIGNATURE    Added here by Module::Build");
  }

  # Would be nice if Module::Signature took a directory argument.

  $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()});
}

sub _do_in_dir {
  my ($self, $dir, $do) = @_;

  my $start_dir = File::Spec->rel2abs($self->cwd);
  chdir $dir or die "Can't chdir() to $dir: $!";
  eval {$do->()};
  my @err = $@ ? ($@) : ();
  chdir $start_dir or push @err, "Can't chdir() back to $start_dir: $!";
  die join "\n", @err if @err;
}

sub ACTION_distsign {
  my ($self) = @_;
  {
    local $self->{properties}{sign} = 0;  # We'll sign it ourselves
    $self->depends_on('distdir') unless -d $self->dist_dir;
  }
  $self->_sign_dir($self->dist_dir);
}

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

  require ExtUtils::Manifest;
  local $^W; # ExtUtils::Manifest is not warnings clean.
  ExtUtils::Manifest::skipcheck();
}

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

  $self->depends_on('realclean');
  $self->depends_on('distcheck');
}

sub do_create_makefile_pl {
  my $self = shift;
  require Module::Build::Compat;
  $self->log_info("Creating Makefile.PL\n");
  eval { Module::Build::Compat->create_makefile_pl($self->create_makefile_pl, $self, @_) };
  if ( $@ ) {
    1 while unlink 'Makefile.PL';
    die "$@\n";
  }
  $self->_add_to_manifest('MANIFEST', 'Makefile.PL');
}

sub do_create_license {
  my $self = shift;
  $self->log_info("Creating LICENSE file\n");

  if (  ! $self->_mb_feature('license_creation') ) {
    $self->_warn_mb_feature_deps('license_creation');
    die "Aborting.\n";
  }

  my $l = $self->license
    or die "Can't create LICENSE file: No license specified\n";

  my $license = $self->_software_license_object
    or die << "HERE";
Can't create LICENSE file: '$l' is not a valid license key
or Software::License subclass;
HERE

  $self->delete_filetree('LICENSE');

  open(my $fh, '>', 'LICENSE')