File Coverage

blib/lib/App/MechaCPAN/Deploy.pm

Criterion	Covered	Total	%
statement	127	181	70.1
branch	21	50	42.0
condition	6	13	46.1
subroutine	16	19	84.2
pod	1	4	25.0
total	171	267	64.0

package App::MechaCPAN::Deploy;

use strict;
use warnings;
use autodie;
use Carp;
use CPAN::Meta;
use List::Util qw/first reduce/;
use File::Temp qw/tempdir/;
use App::MechaCPAN qw/:go/;

our @args = (
  'skip-perl!',
  'update!',
);

sub munge_args
{
  my $class = shift;
  my $opts  = shift;
  my $file  = shift || '.';

  if ( $file =~ git_re )
  {
    my ( $git_url, $branch ) = $file =~ git_extract_re;

    if ( !eval { run(qw/git --version/); 1; } )
    {
      croak "Was given a git-looking URL, but could not run git";
    }

    my $remote      = 'origin';
    my $needs_clone = 1;

    # Determine if we're in a git directory
    if ( -d '.git' || eval { run(qw/git rev-parse --git-dir/); 1 } )
    {
      my $remote_line = first {m/\t $git_url \s/xms} run(qw/git remote -v/);
      if ($remote_line)
      {
        ($remote) = $remote_line =~ m/^ ([^\t]*) \t/xms;

        success "Found git checkout of of $git_url";

        $needs_clone = 0;
      }
      elsif ( -d '.git' )
      {
        # Only croak if there is a .git here which means we can't clone here
        croak "Found git checkout but could not find remote URL $git_url";
      }
    }

    if ($needs_clone)
    {
      info 'git-clone', "Cloning $git_url";

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

      # We use a temp directory and --seperate-git-dir  since byt his point
      # local exists because we're created it and started logging. These
      # options, plus the git config below, allow us to clone a git repo
      # without a clean current directory.
      run qw/git clone/, '--separate-git-dir=.git', '-n', '-o', $remote,
        $git_url, $dir;
      run qw/git config --unset core.worktree/;
      $branch //= 'master';
      success 'git-clone', "Cloned $git_url";
    }

    if ($branch)
    {
      info 'git-branch', "Checking out $branch";
      run qw/git checkout/, $branch;
      run qw/git fetch/, $remote, $branch;
      info 'git-branch', "Merging with remote branch $remote/$branch";
      run qw/git merge --ff-only FETCH_HEAD/;
      success 'git-branch', "Switched branch to $remote/$branch";
    }

    if ( !-f 'cpanfile' )
    {
      my @cpanfiles = glob '*/cpanfile';
      if ( scalar @cpanfiles == 1 )
      {
        my $dir = $cpanfiles[0];
        $dir =~ s[/cpanfile$][]xms;
        chdir $dir;
        $file = 'cpanfile';
      }
    }
  }

  return ($file);
}

sub go
{
  my $class = shift;
  my $opts  = shift;
  my $file  = shift || '.';

  if ( -d $file )
  {
    $file = "$file/cpanfile";
  }

  if ( !-e $file )
  {
    croak "Could not find cpanfile ($file)";
  }

  if ( !-f $file )
  {
    croak "cpanfile must be a regular file";
  }

  my $prereq = parse_cpanfile($file);
  my @phases = qw/configure build test runtime/;

  my @acc = map {%$_} map { values %{ $prereq->{$_} } } @phases;
  my @reqs;
  while (@acc)
  {
    push @reqs, [ splice( @acc, 0, 2 ) ];
  }

  if ( -f "$file.snapshot" )
  {
    my $snapshot_info = parse_snapshot("$file.snapshot");
    my %srcs;
    my %reqs;
    foreach my $dist ( values %$snapshot_info )
    {
      my $src = $dist->{pathname};
      foreach my $provide ( keys %{ $dist->{provides} } )
      {
        if ( exists $srcs{$provide} )
        {
          error "Found duplicate distribution for $provide in $file.snapshot";
          info "  $src and $srcs{$provide} both provide the same module";
          info "  This will cause an error if it is used as a dependency";
          $srcs{$provide} = undef;
          next;
        }
        $srcs{$provide} = $src;
      }

      foreach my $req ( keys %{ $dist->{requirements} } )
      {
        $reqs{$req} = undef;
      }
    }

    if ( ref $opts->{source} eq 'HASH' )
    {
      %srcs = ( %srcs, %{ $opts->{source} } );
    }
    $opts->{source}         = { %reqs, %srcs };
    $opts->{update}         = 0;
    $opts->{'only-sources'} = 1;
    $opts->{'smart-tests'}  = 1
      if !defined $opts->{'smart-tests'};
  }

  my $result;
  $opts->{update} //= 0;

  if ( !$opts->{'skip-perl'} )
  {
    $result = App::MechaCPAN::Perl->go($opts);
    return $result if $result;
  }

  $result = App::MechaCPAN::Install->go( $opts, @reqs );
  return $result if $result;

  return 0;
}

my $sandbox_num = 1;

sub parse_cpanfile
{
  my $file = shift;

  my $result = { runtime => {} };

  $result->{current} = $result->{runtime};

  my $methods = {
    on => sub
    {
      my ( $phase, $code ) = @_;
      local $result->{current} = $result->{$phase} //= {};
      $code->();
    },
    feature => sub {...},
  };

  foreach my $type (qw/requires recommends suggests conflicts/)
  {
    $methods->{$type} = sub
    {
      my ( $module, $ver ) = @_;
      if ( $module eq 'perl' )
      {
        $result->{perl} = $ver;
        return;
      }
      $result->{current}->{$type}->{$module} = $ver;
    };
  }

  foreach my $phase (qw/configure build test author/)
  {
    $methods->{ $phase . '_requires' } = sub
    {
      my ( $module, $ver ) = @_;
      $result->{$phase}->{requires}->{$module} = $ver;
    };
  }

  open my $code_fh, '<', $file;
  my $code = do { local $/; <$code_fh> };

  my $pkg = __PACKAGE__ . "::Sandbox$sandbox_num";
  $sandbox_num++;

  foreach my $method ( keys %$methods )
  {
    no strict 'refs';
    *{"${pkg}::${method}"} = $methods->{$method};
  }

  local $@;
  my $sandbox = join(
    "\n",
    qq[package $pkg;],
    qq[no warnings;],
    qq[# line 1 "$file"],
    qq[$code],
    qq[return 1;],
  );

  my $no_error = eval $sandbox;

  croak $@
    unless $no_error;

  delete $result->{current};

  return $result;
}

my $snapshot_re = qr/^\# carton snapshot format: version 1\.0/;

sub parse_snapshot
{
  my $file = shift;

  my $result = {};

  open my $snap_fh, '<', $file;

  if ( my $line = <$snap_fh> !~ $snapshot_re )
  {
    die "File doesn't looks like a carton snapshot: $file";
  }

  my @stack  = ($result);
  my $prefix = '';
  while ( my $line = <$snap_fh> )
  {
    chomp $line;

    if ( $line =~ m/^ \Q$prefix\E (\S+?) :? $/xms )
    {
      my $new_depth = {};
      $stack[0]->{$1} = $new_depth;
      unshift @stack, $new_depth;
      $prefix = '  ' x $#stack;
      next;
    }

    if ( $line =~ m/^ \Q$prefix\E (\S+?) (?: :? \s (.*) )? $/xms )
    {
      $stack[0]->{$1} = $2;
      next;
    }

    if ( $line !~ m/^ \Q$prefix\E /xms )
    {
      shift @stack;
      $prefix = '  ' x $#stack;
      redo;
    }

    die "Unable to parse snapshot (line $.)\n";
  }

  return $result->{DISTRIBUTIONS};
}

1;
__END__