File Coverage

blib/lib/Perl/Build.pm

Criterion	Covered	Total	%
statement	73	200	36.5
branch	4	78	5.1
condition	2	41	4.8
subroutine	20	30	66.6
pod	4	14	28.5
total	103	363	28.3

package Perl::Build;
use strict;
use warnings;
use utf8;

use 5.008001;
our $VERSION = '1.33';

use Carp ();
use File::Basename;
use File::Spec::Functions qw(catfile catdir rel2abs);
use CPAN::Perl::Releases;
use CPAN::Perl::Releases::MetaCPAN;
use File::pushd qw(pushd);
use File::Temp;
use HTTP::Tinyish;
use JSON::PP qw(decode_json);
use Devel::PatchPerl 0.88;
use Perl::Build::Built;
use Time::Local;

our $CPAN_MIRROR = $ENV{PERL_BUILD_CPAN_MIRROR} || 'https://cpan.metacpan.org';

sub available_perls {
    my $class = shift;

    my $releases = CPAN::Perl::Releases::MetaCPAN->new->get;
    my @available_versions;
    for my $release (@$releases) {
        if ($release->{name} =~ /^perl-(5.(\d+).(\d+)(-\w+)?)$/) {
            my ($version, $major, $minor, $rc) = ($1, $2, $3, $4);
            my $sort_by = sprintf "%03d%03d%s", $major, $minor, $rc || "ZZZ";
            push @available_versions, { version => $version, sort_by => $sort_by };
        }
    }
    map { $_->{version} } sort { $b->{sort_by} cmp $a->{sort_by} } @available_versions;
}

# @return extracted source directory
sub extract_tarball {
    my ($class, $dist_tarball, $destdir) = @_;

    # Was broken on Solaris, where GNU tar is probably
    # installed as 'gtar' - RT #61042
    my $tar = $^O eq 'solaris' ? 'gtar' : 'tar';

    my $type
        = $dist_tarball =~ m/bz2$/  ? 'j'
        : $dist_tarball =~ m/xz$/   ? 'J'
                                    : 'z';

    my $abs_tarball = File::Spec->rel2abs($dist_tarball);

    my @tar_files = `$tar t${type}f "$abs_tarball"`;
    $? == 0
        or die "Failed to extract $dist_tarball";

    chomp @tar_files;
    my %seen;
    my @prefixes = grep !$seen{$_}++, map m{\A(?:\./)?([^/]+)}, @tar_files;

    die "$dist_tarball does not contain single directory : @prefixes"
        if @prefixes != 1;

    system(qq{cd "$destdir"; $tar x${type}f "$abs_tarball"}) == 0
        or die "Failed to extract $dist_tarball";

    return catfile($destdir, $prefixes[0]);
}

sub perl_release {
    my ($class, $version) = @_;

    my ($dist_tarball, $dist_tarball_url);
    my @err;
    for my $func (qw/cpan_perl_releases metacpan/) {
        eval {
            ($dist_tarball, $dist_tarball_url) = $class->can("perl_release_by_$func")->($class,$version);
        };
        push @err, "[$func] $@" if $@;
        last if $dist_tarball && $dist_tarball_url;
    }
    if (!$dist_tarball and !$dist_tarball_url) {
        push @err, "ERROR: Cannot find the tarball for perl-$version\n";
        die join "", @err;
    }

    return ($dist_tarball, $dist_tarball_url);
}

sub perl_release_by_cpan_perl_releases {
    my ($class, $version) = @_;
    my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
    my $x = $tarballs->{'tar.gz'} || $tarballs->{'tar.bz2'} || $tarballs->{'tar.xz'};
    die "not found the tarball for perl-$version\n" unless $x;
    my $dist_tarball = (split("/", $x))[-1];
    my $dist_tarball_url = $CPAN_MIRROR . "/authors/id/$x";
    return ($dist_tarball, $dist_tarball_url);
}

sub perl_release_by_metacpan {
    my ($class, $version) = @_;
    my $releases = CPAN::Perl::Releases::MetaCPAN->new->get;
    for my $release (@$releases) {
        if ($release->{name} eq "perl-$version") {
            my ($path) = $release->{download_url} =~ m{(/authors/id/.*)};
            my $dist_tarball = (split("/", $path))[-1];
            my $dist_tarball_url = $CPAN_MIRROR . $path;
            return ($dist_tarball, $dist_tarball_url);
        }
    }
    die "not found the tarball for perl-$version\n";
}

sub http_get {
    my ($url) = @_;

    my $http = HTTP::Tinyish->new(verify_SSL => 1);
    my $response = $http->get($url);
    if ($response->{success}) {
        return $response->{content};
    } else {
        my $msg = $response->{status} == 599 ? ", $response->{content}" : "";
        chomp $msg;
        die "Cannot get content from $url: $response->{status} $response->{reason}$msg\n";
    }
}

sub http_mirror {
    my ($url, $path) = @_;

    my $http = HTTP::Tinyish->new(verify_SSL => 1);
    my $response = $http->mirror($url, $path);
    if ($response->{success}) {
        print "Downloaded $url to $path.\n";
    } else {
        my $msg = $response->{status} == 599 ? ", $response->{content}" : "";
        chomp $msg;
        die "Cannot get file from $url: $response->{status} $response->{reason}$msg";
    }
}

sub install_from_cpan {
    my ($class, $version, %args) = @_;

    $args{patchperl} && Carp::croak "The patchperl argument was deprected.";

    my $tarball_dir = $args{tarball_dir}
        || File::Temp::tempdir( CLEANUP => 1 );
    my $build_dir = $args{build_dir}
        || File::Temp::tempdir( CLEANUP => 1 );
    my $dst_path = $args{dst_path}
        or die "Missing mandatory parameter: dst_path";
    my $configure_options = $args{configure_options}
        || ['-de'];

    # download tar ball
    my ($dist_tarball, $dist_tarball_url) = Perl::Build->perl_release($version);
    my $dist_tarball_path = catfile($tarball_dir, $dist_tarball);
    if (-f $dist_tarball_path) {
        print "Use the previously fetched ${dist_tarball}\n";
    }
    else {
        print "Fetching $version as $dist_tarball_path ($dist_tarball_url)\n";
        http_mirror( $dist_tarball_url, $dist_tarball_path );
    }

    # and extract tar ball.
    my $dist_extracted_path = Perl::Build->extract_tarball($dist_tarball_path, $build_dir);
    Perl::Build->install(
        src_path          => $dist_extracted_path,
        dst_path          => $dst_path,
        configure_options => $configure_options,
        test              => $args{test},
        jobs              => $args{jobs},
    );
}

sub install_from_url {
    my ($class, $dist_tarball_url, %args) = @_;
    $args{patchperl} && Carp::croak "The patchperl argument was deprected.";

    my $build_dir = $args{build_dir}
        || File::Temp::tempdir( CLEANUP => 1 );
    my $tarball_dir = $args{tarball_dir}
        || File::Temp::tempdir( CLEANUP => 1 );
    my $dst_path = $args{dst_path}
        or die "Missing mandatory parameter: dst_path";
    my $configure_options = $args{configure_options}
        || ['-de'];

    my $dist_tarball = basename($dist_tarball_url);
    my $dist_tarball_path = catfile($tarball_dir, $dist_tarball);
    if (-f $dist_tarball_path) {
        print "Use the previously fetched ${dist_tarball}\n";
    }
    else {
        print "Fetching $dist_tarball_path ($dist_tarball_url)\n";
        http_mirror( $dist_tarball_url, $dist_tarball_path );
    }

    my $dist_extracted_path = Perl::Build->extract_tarball($dist_tarball_path, $build_dir);
    Perl::Build->install(
        src_path          => $dist_extracted_path,
        dst_path          => $dst_path,
        configure_options => $configure_options,
        test              => $args{test},
        jobs              => $args{jobs},
    );
}

sub install_from_tarball {
    my ($class, $dist_tarball_path, %args) = @_;
    $args{patchperl} && Carp::croak "The patchperl argument was deprected.";

    my $build_dir = $args{build_dir}
        || File::Temp::tempdir( CLEANUP => 1 );
    my $dst_path = $args{dst_path}
        or die "Missing mandatory parameter: dst_path";
    my $configure_options = $args{configure_options}
        || ['-de'];

    my $dist_extracted_path = Perl::Build->extract_tarball($dist_tarball_path, $build_dir);
    Perl::Build->install(
        src_path          => $dist_extracted_path,
        dst_path          => $dst_path,
        configure_options => $configure_options,
        test              => $args{test},
        jobs              => $args{jobs},
    );
}

sub install {
    my ($class, %args) = @_;
    $args{patchperl} && Carp::croak "The patchperl argument was deprected.";

    my $src_path = $args{src_path}
        or die "Missing mandatory parameter: src_path";
    my $dst_path = $args{dst_path}
        or die "Missing mandatory parameter: dst_path";
    my $configure_options = $args{configure_options}
        or die "Missing mandatory parameter: configure_options";
    my $jobs = $args{jobs}; # optional
    my $test = $args{test}; # optional

    unshift @$configure_options, qq(-Dprefix=$dst_path);

    # Perl5 installs public executable scripts(like `prove`) to /usr/local/share/
    # if it exists.
    #
    # This -A'eval:scriptdir=$prefix/bin' option avoid this feature.
    unless (grep { /eval:scriptdir=/} @$configure_options) {
        push @$configure_options, "-A'eval:scriptdir=${dst_path}/bin'";
    }

    # clean up environment
    delete $ENV{$_} for qw(PERL5LIB PERL5OPT);

    {
        my $dir = pushd($src_path);

        # determine_version is a public API.
        my $dist_version = Devel::PatchPerl->determine_version();
        print "Configuring perl '$dist_version'\n";

        # clean up
        $class->do_system("rm -f config.sh Policy.sh");

        # apply patches
        Devel::PatchPerl->patch_source();

        # configure
        $class->do_system(['sh', 'Configure', @$configure_options]);
        # patch for older perls
        # XXX is this needed? patchperl do this?
        # if (Perl::Build->perl_version_to_integer($dist_version) < Perl::Build->perl_version_to_integer( '5.8.9' )) {
        #     $class->do_system("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile");
        # }

        # build
        my @make = qw(make);
        if ($ENV{PERL_BUILD_COMPILE_OPTIONS}) {
            push @make, $ENV{PERL_BUILD_COMPILE_OPTIONS};
        }
        if ($jobs) {
            push @make, '-j', $jobs;
        }
        $class->do_system(\@make);
        if ($test) {
            local $ENV{TEST_JOBS} = $jobs if $jobs;
            # Test via "make test_harness" if available so we'll get
            # automatic parallel testing via $HARNESS_OPTIONS. The
            # "test_harness" target was added in 5.7.3, which was the last
            # development release before 5.8.0.
            my $test_target = 'test';
            if ($dist_version && $dist_version =~ /^5\.([0-9]+)\.([0-9]+)/
                && ($1 >= 8 || $1 == 7 && $2 == 3)) {
                $test_target = "test_harness";
            }
            $class->do_system([@make, $test_target]);
        }
	@make = qw(make install);
	if ($ENV{PERL_BUILD_INSTALL_OPTIONS}) {
	    push @make, $ENV{PERL_BUILD_INSTALL_OPTIONS};
	}
        $class->do_system(\@make);
    }
    return Perl::Build::Built->new({
        installed_path => $dst_path,
    });
}

sub do_system {
    my ($class, $cmd) = @_;

    if (ref $cmd eq 'ARRAY') {
        $class->info(join(' ', @$cmd));
        system(@$cmd) == 0
            or die "Installation failure: @$cmd";
    } else {
        $class->info($cmd);
        system($cmd) == 0
            or die "Installation failure: $cmd";
    }
}

sub symlink_devel_executables {
    my ($class, $bin_dir) = @_;

    for my $executable (glob("$bin_dir/*")) {
        my ($name, $version) = basename( $executable ) =~ m/(.+?)(5\.\d.*)?$/;
        if ($version) {
            my $cmd = "ln -fs $executable $bin_dir/$name";
            $class->info($cmd);
            system($cmd);
        }
    }
}

sub info {
    my ($class, @msg) = @_;
    print @msg, "\n";
}

1;
__END__