File Coverage

blib/lib/App/MechaCPAN/Perl.pm

Criterion	Covered	Total	%
statement	110	135	81.4
branch	28	46	60.8
condition	7	18	38.8
subroutine	11	11	100.0
pod	1	1	100.0
total	157	211	74.4

package App::MechaCPAN::Perl;

use v5.14;
use autodie;
use Config;
use File::Fetch qw//;
use App::MechaCPAN qw/:go/;

our @args = (
  'threads!',
  'skip-tests!',
  'skip-local!',
  'skip-lib!',
  'smart-tests!',
  'devel!',
);

my $perl5_ver_re = qr/v? 5 [.] (\d{1,2}) (?: [.] (\d{1,2}) )?/xms;
my $perl5_re     = qr/^ $perl5_ver_re $/xms;

sub go
{
  my $class = shift;
  my $opts  = shift;
  my $src   = shift;
  my @argv  = shift;

  if ( $^O eq 'MSWin32' )
  {
    info 'Cannot build perl on Win32';
    return 0;
  }

  my $orig_dir = &dest_dir;
  my @orig_dir = File::Spec->splitdir("$orig_dir");
  my $orig_len = $#orig_dir;
  my $dest_dir = "$orig_dir/perl";
  my $pv_ver;    # Version in .perl-version file

  # Attempt to find the perl version if none was given
  if ( -f '.perl-version' )
  {
    open my $pvFH, '<', '.perl-version';
    $pv_ver = do { local $/; <$pvFH> };
    $pv_ver =~ s/\s+//xmsg;
    if ( $pv_ver !~ $perl5_re )
    {
      info "$pv_ver in .perl-version doesn't look like a perl5 version";
      undef $pv_ver;
    }
  }

  my ( $src_tz, $version ) = _get_targz( $src // $pv_ver );

  # If _get_targz couldn't find a version, guess based on the file
  if ( !$version && $src_tz =~ m($perl5_ver_re [^/]* $)xms )
  {
    my $major = $1;
    my $minor = $2;

    $version = "5.$major.$minor";
    info("Looks like $src_tz is perl $version, assuming that's true");
  }

  if ( -e -x "$dest_dir/bin/perl" )
  {
    unless ( $opts->{is_restarted_process} )
    {
      # If it exists, we're probably running it by now.
      if ( $version && $^V ne "v$version" )
      {
        info(
          $version,
          "perl has already been installed ($^V, not $version)"
        );
      }
      else
      {
        success( $version, "perl has already been installed" );
      }
    }
    return 0;
  }

  my $verstr = "perl $version";
  info $verstr, "Fetching $verstr";

  my $src_dir = inflate_archive($src_tz);

  chdir $src_dir;

  if ( !-e 'Configure' )
  {
    my @files = glob('*');
    if ( @files > 1 )
    {
      die 'Could not find perl to configure';
    }
    chdir $files[0];
  }

  my $local_dir = File::Spec->catdir( @orig_dir, qw/lib perl5/ );
  my $lib_dir
    = File::Spec->catdir( @orig_dir[ 0 .. $orig_len - 1 ], qw/lib/ );

  my @otherlib = (
    !$opts->{'skip-local'} ? $local_dir : (),
    !$opts->{'skip-lib'} && -d $lib_dir ? $lib_dir : (),
  );

  my @config = (
    q[-des],
    qq[-Dprefix=$dest_dir],
    q[-Accflags=-DAPPLLIB_EXP=\"] . join( ":", @otherlib ) . q[\"],
    qq[-A'eval:scriptdir=$dest_dir/bin'],
  );

  if ( $opts->{threads} )
  {
    push @config, '-Dusethreads';
  }

  if ( $opts->{devel} )
  {
    push @config, '-Dusedevel';
  }

  delete @ENV{qw(PERL5LIB PERL5OPT)};

  # Make sure no tomfoolery is happening with perl, like plenv shims
  $ENV{PATH} = $Config{binexp} . ":$ENV{PATH}";

  eval {
    require Devel::PatchPerl;
    info $verstr, "Patching $verstr";
    Devel::PatchPerl->patch_source();
  };

  info $verstr, "Configuring $verstr";
  _run_configure(@config);

  info $verstr, "Building $verstr";
  _run_make();

  my $skip_tests = $opts->{'skip-tests'};

  if ( !$skip_tests && $opts->{'smart-tests'} )
  {
    $skip_tests = $pv_ver eq $version;
  }

  if ( !$skip_tests )
  {
    info $verstr, "Testing $verstr";
    _run_make('test_harness');
  }

  info $verstr, "Installing $verstr";
  _run_make('install');

  success "Installed $verstr";

  chdir $orig_dir;

  &restart_script();

  return 0;
}

# These are split out mostly so we can control testing
sub _run_configure
{
  my @config = @_;
  run qw[sh Configure], @config;
}

sub _run_make
{
  my @cmd = @_;
  state $make = $Config{make};
  run $make, @cmd;
}

sub _dnld_url
{
  my $version = shift;
  my $minor   = shift;
  my $mirror  = 'http://www.cpan.org/src/5.0';

  return "$mirror/perl-5.$version.$minor.tar.bz2";
}

sub _get_targz
{
  my $src = shift;

  local $File::Fetch::WARN;

  # If there's no src, find the newest version.
  if ( !defined $src )
  {
    # Do a terrible job of guessing what the current version is
    use Time::localtime;
    my $year = localtime->year() + 1900;

    # 5.12 was released in 2010, and approximatly every May, a new even
    # version was released
    my $major = ( $year - 2010 ) * 2 + ( localtime->mon < 4 ? 10 : 12 );

    # Verify our guess
    {
      my $dnld = _dnld_url( $major, 0 ) . ".md5.txt";
      my $ff       = File::Fetch->new( uri => $dnld );
      my $contents = '';
      my $where    = $ff->fetch( to => \$contents );

      if ( !defined $where && $major > 12 )
      {
        $major -= 2;
        redo;
      }
    }
    $src = "5.$major";
  }

  # file

  if ( -e $src )
  {
    return ( $src, '' );
  }

  my $url;

  # URL
  if ( $src =~ url_re )
  {
    return ( $src, '' );
  }

  # CPAN
  if ( $src =~ $perl5_re )
  {
    my $version = $1;
    my $minor   = $2;

    # They probably want the latest if minor wasn't given
    if ( !defined $minor )
    {
      # 11 is the highest minor version seen as of this writing
      my @possible = ( 0 .. 15 );

      while ( @possible > 1 )
      {
        my $i = int( @possible / 2 );
        $minor = $possible[$i];
        my $dnld = _dnld_url( $version, $minor ) . ".md5.txt";
        my $ff       = File::Fetch->new( uri => $dnld );
        my $contents = '';
        my $where    = $ff->fetch( to => \$contents );

        if ( defined $where )
        {
          # The version exists, which means it's higher still
          @possible = @possible[ $i .. $#possible ];
        }
        else
        {
          # The version doesn't exit. That means higher versions don't either
          @possible = @possible[ 0 .. $i - 1 ];
        }
      }
      $minor = $possible[0];
    }

    return ( _dnld_url( $version, $minor ), "5.$version.$minor" );
  }

  die "Cannot find $src\n";
}

1;
__END__