File Coverage

blib/lib/App/MechaCPAN/Install.pm

Criterion	Covered	Total	%
statement	465	483	96.2
branch	137	164	83.5
condition	39	53	73.5
subroutine	46	46	100.0
pod	1	1	100.0
total	688	747	92.1

package App::MechaCPAN::Install;

use v5.14;

use Config;
use Cwd qw/cwd/;
use JSON::PP qw//;
use File::Spec qw//;
use File::Path qw//;
use File::Temp qw/tempdir tempfile/;
use CPAN::Meta qw//;
use CPAN::Meta::Prereqs qw//;
use File::Fetch qw//;
use Module::CoreList;
use ExtUtils::MakeMaker qw//;
use App::MechaCPAN qw/:go/;

our @args = (
  'skip-tests!',
  'skip-tests-for:s@',
  'smart-tests!',
  'install-man!',
  'source=s%',
  'only-sources!',
  'update!',
  'stop-on-error!',
);

our $dest_lib;

# Constants
my $COMPLETE = 'COMPLETE';
my $FAILED   = 'FAILED';

sub go
{
  my $class = shift;
  my $opts  = shift;
  my $src   = shift // '.';
  my @srcs  = @_;

  my $orig_dir = cwd;
  my $dest_dir = &dest_dir;

  local $dest_lib = "$dest_dir/lib/perl5";

  my @targets = ( $src, @srcs );
  my %src_names;
  my @deps;

  if ( ref $opts->{source} ne 'HASH' && ref $opts->{source} ne 'CODE' )
  {
    $opts->{source} = {};
  }

  if ( ref $opts->{'skip-tests-for'} ne 'ARRAY' )
  {
    $opts->{'skip-tests-for'} = [];
  }
  $opts->{'skip-tests-for'}
    = { map { $_ => 1 } @{ $opts->{'skip-tests-for'} } };

  my $unsafe_inc
    = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1;

  # trick AutoInstall
  local $ENV{PERL5_CPAN_IS_RUNNING}     = $$;
  local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;

  local $ENV{PERL_MM_USE_DEFAULT} = 1;
  local $ENV{PERL_USE_UNSAFE_INC} = $unsafe_inc;

  local $ENV{PERL_MM_OPT} = "INSTALL_BASE=$dest_dir";
  local $ENV{PERL_MB_OPT} = "--install_base $dest_dir";

  local $ENV{PERL5LIB} = "$dest_lib";

  # skip man page generation
  if ( !$opts->{'install-man'} )
  {
    $ENV{PERL_MM_OPT}
      .= " " . join( " ", "INSTALLMAN1DIR=none", "INSTALLMAN3DIR=none" );
    $ENV{PERL_MB_OPT} .= " " . join(
      " ",                            "--config installman1dir=",
      "--config installsiteman1dir=", "--config installman3dir=",
      "--config installsiteman3dir="
    );
  }

  #if ( $self->{pure_perl} )
  #{
  #  $ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1";
  #  $ENV{PERL_MB_OPT} .= " --pureperl-only";
  #}

  my $cache = { opts => $opts };

  # Prepopulate all of the sources as targets
  foreach my $source_key ( keys %{ $opts->{source} } )
  {
    my $source = $opts->{source}->{$source_key};

    # If there is no source to translate to, continue
    if ( !defined $source )
    {
      _create_target( $source_key, $cache );
      next;
    }

    # If we can find a target, reuse it, otherwise create a new one
    my $target = _find_target( $source, $cache );
    if ( defined $target )
    {
      _alias_target( $target, $source_key, $cache );
    }
    else
    {
      $target = _create_target( $source_key, $cache );
      _alias_target( $target, $source, $cache );
    }
  }

  my @full_states = (
    'Resolving'     => \&_resolve,
    'Configuring'   => \&_meta,
    'Configuring'   => \&_config_prereq,
    'Configuring'   => \&_configure,
    'Configuring'   => \&_mymeta,
    'Prerequisites' => \&_prereq,
    'Prerequisites' => \&_test_prereq,
    'Prerequisites' => \&_prereq_verify,
    'Building'      => \&_build,
    'Testing'       => \&_test,
    'Installing'    => \&_install,
    'Installed'     => \&_write_meta,
  );

  my @states     = grep { ref $_ eq 'CODE' } @full_states;
  my @state_desc = grep { ref $_ ne 'CODE' } @full_states;

  foreach my $target (@targets)
  {
    $target = _create_target( $target, $cache );
    $target->{update} = $opts->{update} // 1;
  }

TARGET:
  while ( my $target = shift @targets )
  {
    $target = _create_target( $target, $cache );

    if ( $target->{state} eq $COMPLETE || $target->{state} eq $FAILED )
    {
      next;
    }

    chdir $orig_dir;
    chdir $target->{dir}
      if exists $target->{dir};

    my $line = _target_line( $target, $state_desc[ $target->{state} ] );
    info( $target->{key}, $line );
    my $method = $states[ $target->{state} ];

    {
      local $@;
      my $succ = eval { unshift @targets, $method->( $target, $cache ); 1; };
      my $err = $@;

      if ( !$succ )
      {
        my $line = sprintf(
          '%-13s %s', 'Error',
          "Could not install " . _name_target($target)
        );

        error( $target->{key}, $line );

        _failed($target);

        if ( $opts->{'stop-on-error'} )
        {
          die $err;
        }

        next TARGET;
      }
    }

    $target->{state}++
      if $target->{state} ne $COMPLETE;

    if ( $target->{state} eq scalar @states )
    {
      _complete($target);
      $target->{was_installed} = 1;
      success( $target->{key}, $line );
    }
  }

  chdir $orig_dir;

  my %attempted = map  { $_->{name} => $_ } values %{ $cache->{targets} };
  my @failed    = grep { $_->{state} eq $FAILED } values %attempted;
  my @installed = grep { $_->{was_installed} } values %attempted;

  success "\tsuccess", "Installed " . scalar @installed . " modules";

  if ( @failed > 0 )
  {
    logmsg "Failed modules: " . join( ", ", @failed );
    die "Failed to install " . scalar @failed . " modules\n";
  }

  return 0;
}

sub _resolve
{
  my $target = shift;
  my $cache  = shift;

  # Verify we need to install it
  return
    if !_should_install($target);

  my $src_name = $target->{src_name};

  $target->{src_name} = _source_translate( $src_name, $cache->{opts} );

  # fetch
  my $src_tgz = _get_targz($target);

  return
    if !_should_install($target);

  my $src_dir = inflate_archive($src_tgz);

  my @files = glob( $src_dir . '/*' );
  if ( @files == 1 )
  {
    $src_dir = $files[0];
  }

  @{$target}{qw/src_tgz dir was_installed/} = ( $src_tgz, $src_dir, 0 );
  return $target;
}

sub _meta
{
  my $target = shift;
  my $cache  = shift;

  $target->{meta} = _load_meta( $target, $cache, 0 );
  return $target;
}

sub _config_prereq
{
  my $target = shift;
  my $cache  = shift;

  my $meta = $target->{meta};

  return $target
    if !defined $meta;

  my @config_deps = _phase_prereq( $target, $cache, 'configure' );

  $target->{configure_prereq} = [@config_deps];

  return @config_deps, $target;
}

sub _configure
{
  my $target = shift;
  my $cache  = shift;
  my $meta   = $target->{meta};

  state $mb_deps = { map { $_ => 1 }
      qw/version ExtUtils-ParseXS ExtUtils-Install ExtUtilsManifest/ };

  # meta may not be defined, so wrap it in an eval
  my $is_mb_dep = eval { exists $mb_deps->{ $meta->name } };
  my $maker;

  if ( -e 'Build.PL' && !$is_mb_dep )
  {
    run( $^X, 'Build.PL' );
    my $configured = -e -f 'Build';
    die 'Unable to configure Buid.PL for ' . $target->{src_name}
      unless $configured;
    $maker = 'mb';
  }

  if ( !defined $maker && -e 'Makefile.PL' )
  {
    run( $^X, 'Makefile.PL' );
    my $configured = -e 'Makefile';
    die 'Unable to configure Makefile.PL for ' . $target->{src_name}
      unless $configured;
    $maker = 'mm';
  }

  die 'Unable to configure ' . $target->{src_name}
    if !defined $maker;

  $target->{maker} = $maker;
  return $target;
}

sub _mymeta
{
  my $target = shift;
  my $cache  = shift;

  my $new_meta = _load_meta( $target, $cache, 1 );
  $target->{meta} = $new_meta
    if defined $new_meta;

  $target->{name} = $target->{meta}->name;
  $target->{name} =~ s[-][::]xmsg;

  return $target;
}

sub _prereq
{
  my $target = shift;
  my $cache  = shift;

  my $meta = $target->{meta};

  my @deps = map { _phase_prereq( $target, $cache, $_ ) } qw/runtime build/;

  $target->{prereq} = [@deps];

  return @deps, $target;
}

sub _test_prereq
{
  my $target = shift;
  my $cache  = shift;

  my $meta = $target->{meta};
  my $opts = $cache->{opts};

  my $skip_tests = $opts->{'skip-tests'};
  if ( !$skip_tests )
  {
    my $skips = $opts->{'skip-tests-for'};
    $skip_tests = exists $skips->{ $target->{src_name} };

    if ( !$skip_tests && defined $target->{modules} )
    {
      foreach my $module ( %{ $target->{modules} } )
      {
        if ( $skips->{$module} )
        {
          $skip_tests = 1;
          last;
        }
      }
    }

    if ( !$skip_tests && $opts->{'smart-tests'} )
    {
      $skip_tests = _target_prereqs_were_installed( $target, $cache );
    }
  }

  $target->{skip_tests} = $skip_tests;

  my @deps;

  if ( !$skip_tests )
  {
    @deps = map { _phase_prereq( $target, $cache, $_ ) } qw/test/;
    push @{ $target->{prereq} }, @deps;
  }

  return @deps, $target;
}

sub _prereq_verify
{
  my $target = shift;
  my $cache  = shift;

  my @deps = _target_prereqs( $target, $cache );
  my @incomplete_deps = grep { $_->{state} ne $COMPLETE } @deps;

  if ( @incomplete_deps > 0 )
  {
    my $line = 'Unmet dependencies for: ' . $target->{src_name};
    error $target->{key}, $line;
    logmsg "Missing requirements: "
      . join( ", ", map { $_->{src_name} } @incomplete_deps );
    die 'Error with prerequisites';
  }

  return $target;
}

sub _build
{
  my $target = shift;
  my $cache  = shift;

  local $ENV{PERL_MM_USE_DEFAULT}    = 0;
  local $ENV{NONINTERACTIVE_TESTING} = 0;
  state $make = $Config{make};

  my $opts = $cache->{opts};

  if ( $target->{maker} eq 'mb' )
  {
    run( $^X, './Build' );
    return $target;
  }

  if ( $target->{maker} eq 'mm' )
  {
    run($make);
    return $target;
  }

  die 'Unable to determine how to install ' . $target->{meta}->name;
}

sub _test
{
  my $target = shift;
  my $cache  = shift;

  local $ENV{PERL_MM_USE_DEFAULT}    = 0;
  local $ENV{NONINTERACTIVE_TESTING} = 0;
  state $make = $Config{make};

  my $opts = $cache->{opts};

  if ( $target->{skip_tests} )
  {
    return $target;
  }

  if ( $target->{maker} eq 'mb' )
  {
    run( $^X, './Build', 'test' );
    return $target;
  }

  if ( $target->{maker} eq 'mm' )
  {
    run( $make, 'test' );
    return $target;
  }

  die 'Unable to determine how to install ' . $target->{meta}->name;
}

sub _install
{
  my $target = shift;
  my $cache  = shift;

  local $ENV{PERL_MM_USE_DEFAULT}    = 0;
  local $ENV{NONINTERACTIVE_TESTING} = 0;
  state $make = $Config{make};

  my $opts = $cache->{opts};

  if ( $target->{maker} eq 'mb' )
  {
    run( $^X, './Build', 'install' );
    return $target;
  }

  if ( $target->{maker} eq 'mm' )
  {
    run( $make, 'install' );
    return $target;
  }

  die 'Unable to determine how to install ' . $target->{meta}->name;
}

sub _write_meta
{
  my $target = shift;
  my $cache  = shift;

  state $arch_dir = "$Config{archname}/.meta/";

  if ( $target->{is_cpan} )
  {
    my $dir = "$dest_lib/$arch_dir/" . $target->{distvname};
    File::Path::mkpath( $dir, 0, 0777 );
    $target->{meta}->save("$dir/MYMETA.json");

    my $install = {
      name     => $target->{name},
      target   => $target->{src_name},
      version  => $target->{meta}->version,
      dist     => $target->{distvname},
      pathname => $target->{pathname},
      provides => $target->{meta}->provides,
    };

    open my $fh, ">", "$dir/install.json";
    print $fh JSON::PP::encode_json($install);
  }
  return;
}

my $full_pause_re = qr[
  (?: authors/id/ )
  (   \w / \w\w )
  /
  ( \w{2,} )
  /
  ( [^/]+ )
]xms;
my $pause_re = qr[
  ^

  (?: authors/id/ )?
  (?: \w / \w\w /)?

  ( \w{2,} )
  /
  ( .+ )

  $
]xms;

sub _escape
{
  my $str = shift;
  $str =~ s/ ([^A-Za-z0-9\-\._~]) / sprintf("%%%02X", ord($1)) /xmsge;
  return $str;
}

my $ident_re = qr/^ \p{ID_Start} (?: :: | \p{ID_Continue} )* $/xms;

sub _src_normalize
{
  my $target = shift;

  if ( ref $target eq '' )
  {
    if ( $target =~ m{^ ([^/]+) @ (.*) $}xms )
    {
      $target = [ $1, "==$2" ];
    }
    else
    {
      $target = [ split /[~]/xms, $target, 2 ];
    }
  }

  if ( ref $target eq 'ARRAY' )
  {
    $target = {
      src_name   => $target->[0],
      constraint => $target->[1],
    };
  }

  return {
    src_name   => $target->{src_name},
    constraint => $target->{constraint},
  };
}

sub _find_target
{
  my $target = shift;
  my $cache  = shift;

  my $src      = _src_normalize($target);
  my $src_name = $src->{src_name};

  return $cache->{targets}->{$src_name};
}

sub _alias_target
{
  my $target = shift;
  my $alias  = shift;
  my $cache  = shift;

  my $target = _find_target( $target, $cache );

  if ( $alias =~ $ident_re )
  {
    $target->{modules}->{$alias} = {
      inital_version => _get_mod_ver($alias),
    };
  }

  $cache->{targets}->{$alias} = $target;
  return;
}

sub _create_target
{
  my $target = shift;
  my $cache  = shift;

  my $src = _src_normalize($target);
  my $cached_target = _find_target( $target, $cache );

  if ( !defined $cached_target )
  {
    my $src_name = $src->{src_name};

    $cached_target = { %$src, state => 0 };
    $cache->{targets}->{$src_name} = $cached_target;
    $cached_target->{key} = $src_name;
  }

  if ( $cached_target->{state} eq $COMPLETE
    && $src->{constraint} ne $cached_target->{constraint} )
  {
    $cached_target->{constraint} = $src->{constraint};
    $cached_target->{state}      = 0;
    delete $cached_target->{version};
  }

  for my $altkey (qw/distvname name module/)
  {
    my $altname = $cached_target->{$altkey};
    if ( defined $altname )
    {
      if ( !exists $cache->{targets}->{$altname} )
      {
        _alias_target( $cached_target, $altname, $cache );
      }
    }
  }

  if ( $src->{src_name} =~ $ident_re )
  {
    $cached_target->{module} = $src->{src_name};
  }

  return $cached_target;
}

sub _target_prereqs
{
  my $target = shift;
  my $cache  = shift;

  return
    map { _find_target $_, $cache }
    ( @{ $target->{prereq} }, @{ $target->{configure_prereq} } );
}

sub _target_prereqs_were_installed
{
  my $target = shift;
  my $cache  = shift;

  foreach my $prereq ( _target_prereqs( $target, $cache ) )
  {
    _target_prereqs_were_installed( $prereq, $cache );

    if ( !$prereq->{prereqs_was_installed} || !$prereq->{was_installed} )
    {
      return $target->{prereqs_was_installed} = 0;
    }
  }

  return $target->{prereqs_was_installed} = 1;
}

sub _search_metacpan
{
  my $src        = shift;
  my $constraint = shift;

  state %seen;

  return $seen{$src}->{$constraint}
    if exists $seen{$src}->{$constraint};

  # TODO mirrors
  my $dnld = 'https://fastapi.metacpan.org/download_url/' . _escape($src);
  if ( defined $constraint )
  {
    $dnld .= '?version=' . _escape($constraint);
  }

  local $File::Fetch::WARN;
  my $ff = File::Fetch->new( uri => $dnld );
  $ff->scheme('http')
    if $ff->scheme eq 'https';
  my $json_info = '';
  my $where = $ff->fetch( to => \$json_info );

  die "Could not find module $src on metacpan"
    if !defined $where;

  my $result = JSON::PP::decode_json($json_info);
  $seen{$src}->{$constraint} = $result;

  return $result;
}

sub _get_targz
{
  my $target = shift;

  my $src = $target->{src_name};

  if ( -e -f $src )
  {
    return $src;
  }

  my $url;

  # git
  if ( $src =~ git_re )
  {
    my ( $git_url, $commit ) = $src =~ git_extract_re;

    my $dir
      = tempdir( TEMPLATE => File::Spec->tmpdir . '/mechacpan_XXXXXXXX' );
    my ( $fh, $file ) = tempfile(
      TEMPLATE => File::Spec->tmpdir . '/mechacpan_tar.gz_XXXXXXXX',
      CLEANUP  => 1
    );

    run( 'git', 'clone', '--bare', $git_url, $dir );
    run(
      $fh, 'git', 'archive', '--format=tar.gz', "--remote=$dir",
      $commit || 'master'
    );
    close $fh;
    return $file;
  }

  # URL
  if ( $src =~ url_re )
  {
    $url = $src;
  }

  # PAUSE
  if ( $src =~ $pause_re )
  {
    my $author  = $1;
    my $package = $2;
    $url = join(
      '/',
      'https://cpan.metacpan.org/authors/id',
      substr( $author, 0, 1 ),
      substr( $author, 0, 2 ),
      $author,
      $package,
    );

    $target->{is_cpan} = 1;
  }

  # Module Name
  if ( !defined $url )
  {
    my $json_data = _search_metacpan( $src, $target->{constraint} );

    $url = $json_data->{download_url};

    $target->{is_cpan} = 1;
    $target->{version} = version->parse( $json_data->{version} );
  }

  if ( defined $url )
  {
    # if it's pause like, parse out the distibution's version name
    if ( $url =~ $full_pause_re )
    {
      my $package = $3;
      $target->{pathname} = "$1/$2/$3";
      $package =~ s/ (.*) [.] ( tar[.](gz|z|bz2) | zip | tgz) $/$1/xmsi;
      $target->{distvname} = $package;
    }

    local $File::Fetch::WARN;
    my $ff = File::Fetch->new( uri => $url );
    my $dest_dir = dest_dir() . "/pkgs";

    $ff->scheme('http')
      if $ff->scheme eq 'https';
    my $where = $ff->fetch( to => $dest_dir );
    die $ff->error || "Could not download $url"
      if !defined $where;

    return $where;
  }

  die "Cannot find $src\n";
}

sub _get_mod_ver
{
  my $module = shift;
  return $]
    if $module eq 'perl';
  local $@;
  my $ver = eval {
    my $file = _installed_file_for_module($module);
    MM->parse_version($file);
  };

  if ( !defined $ver )
  {
    $ver = $Module::CoreList::version{$]}{$module};
  }

  return $ver;
}

sub _load_meta
{
  my $target = shift;
  my $cache  = shift;
  my $my     = shift;

  my $prefix = $my ? 'MYMETA' : 'META';

  my $meta;

  foreach my $file ( "$prefix.json", "$prefix.yml" )
  {
    $meta = eval { CPAN::Meta->load_file($file) };
    last
      if defined $meta;
  }

  return $meta;
}

sub _phase_prereq
{
  my $target = shift;
  my $cache  = shift;
  my $phase  = shift;

  my $prereqs = $target->{meta}->effective_prereqs;
  my @result;

  my $requirements = $prereqs->requirements_for( $phase, "requires" );
  my $reqs = $requirements->as_string_hash;
  for my $module ( sort keys %$reqs )
  {
    my $is_core;

    if ( exists $Module::CoreList::version{$]}{$module} )
    {
      my $version = $Module::CoreList::version{$]}{$module};
      $is_core = $requirements->accepts_module( $module, $version );
    }

    push @result, [ $module, $reqs->{$module} ]
      if $module ne 'perl' && !$is_core;
  }

  return @result;
}

sub _installed_file_for_module
{
  my $prereq = shift;
  my $file   = "$prereq.pm";
  $file =~ s{::}{/}g;

  state $archname = $Config{archname};
  state $perlver  = $Config{version};

  for my $dir (
    "$dest_lib/$archname",
    "$dest_lib",
    )
  {
    my $tmp = File::Spec->catfile( $dir, $file );
    return $tmp
      if -r $tmp;
  }
}

sub _should_install
{
  my $target = shift;

  return 1
    unless defined $target->{module};

  my $module = $target->{module};
  my $ver    = _get_mod_ver($module);

  $target->{installed_version} = $ver;

  return 1
    if !defined $ver;

  my $msg = 'Up to date';

  $msg = 'Installed'
    if $target->{was_installed};

  if ( !$target->{update} )
  {
    my $constraint = $target->{constraint};
    my $prereq     = CPAN::Meta::Prereqs->new(
      { runtime => { requires => { $module => $constraint // 0 } } } );
    my $req = $prereq->requirements_for( 'runtime', 'requires' );

    if ( $req->accepts_module( $module, $ver ) )
    {
      success(
        $target->{key},
        _target_line( $target, $msg )
      );
      _complete($target);
      return;
    }
  }

  if ( defined $target->{version} && $target->{version} eq $ver )
  {
    success(
      $target->{key},
      _target_line( $target, $msg )
    );
    _complete($target);
    return;
  }

  return 1;
}

sub _source_translate
{
  my $src_name = shift;
  my $opts     = shift;
  my $sources  = $opts->{source};

  my $new_src;

  if ( ref $sources eq 'HASH' )
  {
    $new_src = $sources->{$src_name};
  }

  if ( ref $sources eq 'CODE' )
  {
    $new_src = $sources->($src_name);
  }

  if ( $opts->{'only-sources'} && !defined $new_src )
  {
    if ( exists $Module::CoreList::version{$]}{$src_name} )
    {
      return $src_name;
    }

    die "Unable to locate $src_name from the sources list\n";
  }

  return defined $new_src ? $new_src : $src_name;
}

sub _complete
{
  my $target = shift;
  $target->{state} = $COMPLETE;

  # If we are marking complete because the installed version is the Core
  # version, mark that it "was_installed"
  if ( exists $target->{installed_version} && !$target->{was_installed} )
  {
    my $module = $target->{module};
    my $ver    = $target->{installed_version};

    $target->{was_installed} = 1
      if $ver eq $Module::CoreList::version{$]}{$module};
  }

  if ( exists $target->{inital_version}
    && !defined $target->{inital_version} )
  {
    # If the module was initally not installed but now is, we probbaly
    # installed it by another package name, so mark it as was_installed
    $target->{was_installed} = 1
      if defined _get_mod_ver( $target->{module} );
  }

  return;
}

sub _failed
{
  my $target = shift;
  $target->{state} = $FAILED;
  return;
}

sub _name_target
{
  my $target = shift;
  return $target->{name} || $target->{module} || $target->{src_name};
}

sub _target_line
{
  my $target = shift;
  my $status = shift;

  my $line = sprintf( '%-13s %s', $status, _name_target($target) );

  return $line;
}

1;
__END__