App-perlbrew

 view release on metacpan or  search on metacpan

lib/App/perlbrew.pm  view on Meta::CPAN

package App::perlbrew;
use strict;
use warnings;
use 5.008;
our $VERSION = "1.02";
use Config qw( %Config );

BEGIN {
    # Special treat for Cwd to prevent it to be loaded from somewhere binary-incompatible with system perl.
    my @oldinc = @INC;

    @INC = (
        $Config{sitelibexp} . "/" . $Config{archname},
        $Config{sitelibexp}, @Config{qw<vendorlibexp vendorarchexp archlibexp privlibexp>},
    );

    require Cwd;
    @INC = @oldinc;
}

use Getopt::Long ();
use CPAN::Perl::Releases ();
use JSON::PP qw( decode_json );
use File::Copy qw( copy move );
use Capture::Tiny ();

use App::Perlbrew::Util qw( files_are_the_same uniq find_similar_tokens looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl make_skaji_relocatable_perl_url );
use App::Perlbrew::Path ();
use App::Perlbrew::Path::Root ();
use App::Perlbrew::HTTP qw( http_download http_get );
use App::Perlbrew::Patchperl qw( maybe_patchperl );
use App::Perlbrew::Sys;

### global variables

# set $ENV{SHELL} to executable path of parent process (= shell) if it's missing
# (e.g. if this script was executed by a daemon started with "service xxx start")
# ref: https://github.com/gugod/App-perlbrew/pull/404
$ENV{SHELL} ||= App::Perlbrew::Path->new( "/proc", getppid, "exe" )->readlink if -d "/proc";

local $SIG{__DIE__} = sub {
    my $message = shift;
    warn $message;
    exit(1);
};

our $CONFIG;
our $PERLBREW_ROOT;
our $PERLBREW_HOME;

my @flavors = (
    {
        d_option => 'usethreads',
        implies  => 'multi',
        common   => 1,
        opt      => 'thread|threads'
    },    # threads is for backward compatibility

    {
        d_option => 'usemultiplicity',
        opt      => 'multi'
    },

    {
        d_option => 'uselongdouble',
        common   => 1,
        opt      => 'ld'
    },

    {
        d_option => 'use64bitint',
        common   => 1,
        opt      => '64int'
    },

    {
        d_option => 'use64bitall',
        implies  => '64int',
        opt      => '64all'
    },

    {
        d_option => 'DEBUGGING',
        opt      => 'debug'
    },

    {

lib/App/perlbrew.pm  view on Meta::CPAN

    $self->do_install_url("https://github.com/Perl/perl5/archive/blead.tar.gz");
}

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

    my ( $latest_ver, $latest_minor );
    for my $cand ( $self->available_perls ) {
        my ( $ver, $minor ) = $cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/
            or next;
        ( $latest_ver, $latest_minor ) = ( $ver, $minor )
            if !defined $latest_minor
            || $latest_minor < $minor;
    }

    die "Can't determine latest stable Perl release\n"
        if !defined $latest_ver;

    return $latest_ver;
}

sub do_install_release {
    my ( $self, $dist, $dist_version ) = @_;

    my $rd        = $self->release_detail($dist);
    my $dist_type = $rd->{type};

    die "\"$dist\" does not look like a perl distribution name. " unless $dist_type && $dist_version =~ /^\d\./;

    my $dist_tarball      = $rd->{tarball_name};
    my $dist_tarball_url  = $rd->{tarball_url};
    my $dist_tarball_path = $self->root->dists($dist_tarball);

    if ( -f $dist_tarball_path ) {
        print "Using the previously fetched ${dist_tarball}\n"
            if $self->{verbose};
    }
    else {
        print "Fetching perl $dist_version as $dist_tarball_path\n" unless $self->{quiet};
        $self->run_command_download($dist);
    }

    my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
    $self->do_install_this( $dist_extracted_path, $dist_version, $dist );
    return;
}

sub run_command_install {
    my ( $self, $dist, $opts ) = @_;

    unless ( $self->root->exists ) {
        die( "ERROR: perlbrew root " . $self->root . " does not exist. Run `perlbrew init` to prepare it first.\n" );
    }

    unless ($dist) {
        $self->run_command_help("install");
        exit(-1);
    }

    if ( my $url = make_skaji_relocatable_perl_url($dist, $self->sys) ) {
        return $self->run_command_install($url);
    }

    if ( my $detail = looks_like_url_of_skaji_relocatable_perl($dist) ) {
        if (looks_like_sys_would_be_compatible_with_skaji_relocatable_perl($detail, $self->sys)) {
            return $self->do_install_skaji_relocatable_perl($detail);
        } else {
            die "ERROR: The given url points to a tarball for different os/arch.\n";
        }
    }

    $self->{dist_name} = $dist;    # for help msg generation, set to non
                                   # normalized name

    my ( $dist_type, $dist_version );
    if ( ( $dist_type, $dist_version ) = $dist =~ /^(?:(c?perl)-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/ ) {
        $dist_version = $self->resolve_stable_version if $dist_version eq 'stable';
        $dist_type ||= "perl";
        $dist = "${dist_type}-${dist_version}";    # normalize dist name

        my $installation_name = ( $self->{as} || $dist ) . $self->{variation} . $self->{append};
        if ( not $self->{force} and $self->is_installed($installation_name) ) {
            die "\nABORT: $installation_name is already installed.\n\n";
        }

        if ( $dist_type eq 'perl' && $dist_version eq 'blead' ) {
            $self->do_install_blead();
        }
        else {
            $self->do_install_release( $dist, $dist_version );
        }

    }

    # else it is some kind of special install:
    elsif ( -d "$dist/.git" ) {
        $self->do_install_git($dist);
    }
    elsif ( -f $dist ) {
        $self->do_install_archive( App::Perlbrew::Path->new($dist) );
    }
    elsif ( $dist =~ m/^(?:https?|ftp|file)/ ) {    # more protocols needed?
        $self->do_install_url($dist);
    }
    else {
        die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` "
            . "for the instruction on using the install command.\n\n";
    }

    if ( $self->{switch} ) {
        if ( defined( my $installation_name = $self->{installation_name} ) ) {
            $self->switch_to($installation_name);
        }
        else {
            warn "can't switch, unable to infer final destination name.\n\n";
        }
    }
    return;
}

sub check_and_calculate_variations {
    my $self = shift;
    my @both = @{ $self->{both} };

    if ( $self->{'all-variations'} ) {
        @both = keys %flavor;

lib/App/perlbrew.pm  view on Meta::CPAN

        if $test_target eq "test_harness" && ( $self->{j} || 1 ) > 1;

    my @install_commands = ( "${make} install" . ( $destdir ? " DESTDIR=$destdir" : q|| ) );
    unshift @install_commands, "${make} $test_target" unless $self->{notest};

  # Whats happening here? we optionally join with && based on $self->{force}, but then subsequently join with && anyway?
    @install_commands = join " && ", @install_commands unless ( $self->{force} );

    my $cmd = join " && ", ( @preconfigure_commands, @configure_commands, @build_commands, @install_commands );

    $self->{log_file}->unlink;

    if ( $self->{verbose} ) {
        $cmd = "($cmd) 2>&1 | tee $self->{log_file}";
        print "$cmd\n" if $self->{verbose};
    }
    else {
        $cmd = "($cmd) >> '$self->{log_file}' 2>&1 ";
    }

    delete $ENV{$_} for qw(PERL5LIB PERL5OPT AWKPATH NO_COLOR);

    if ( $self->do_system($cmd) ) {
        my $newperl = $self->root->perls($installation_name)->perl;
        unless ( -e $newperl ) {
            $self->run_command_symlink_executables($installation_name);
        }

        eval { $self->append_log('##### Brew Finished #####') };

        if ($sitecustomize) {
            my $capture = $self->do_capture("$newperl -V:sitelib");
            my ($sitelib) = $capture =~ m/sitelib='([^']*)';/;
            $sitelib = $destdir . $sitelib if $destdir;
            $sitelib = App::Perlbrew::Path->new($sitelib);
            $sitelib->mkpath;
            my $target = $sitelib->child("sitecustomize.pl");
            open my $dst, ">", $target
                or die "Could not open '$target' for writing: $!\n";
            open my $src, "<", $sitecustomize
                or die "Could not open '$sitecustomize' for reading: $!\n";
            print {$dst} do { local $/; <$src> };
        }

        my $version_file = $self->root->perls($installation_name)->version_file;

        if ( -e $version_file ) {
            $version_file->unlink()
                or die "Could not unlink $version_file file: $!\n";
        }

        print "$installation_name is successfully installed.\n";
    }
    else {
        eval { $self->append_log('##### Brew Failed #####') };
        die $self->INSTALLATION_FAILURE_MESSAGE;
    }
    return;
}

sub do_install_skaji_relocatable_perl {
    my ($self, $detail) = @_;

    my $installation_name = $self->{as} || ("skaji-relocatable-perl-" . $detail->{version});
    my $installation_path = $self->root->perls->child($installation_name);

    die "ERROR: Installation target \"${installation_name}\" already exists\n"
        if $installation_path->exists;

    my $path = $self->root->dists
        ->child("skaji-relocatable-perl")
        ->child($detail->{version})
        ->mkpath()
        ->child($detail->{original_filename});

    if (-f $path) {
        print "Re-using the downloaded $path\n";
    } else {
        my $url = $detail->{url};
        print "Downloading $url as $path\n";
        my $error = http_download( $detail->{url}, $path );
        if ($error) {
            die "Failed to download from $url\nError: $error";
        }
    }

    my $extracted_path = $self->do_extract_skaji_relocatable_perl_tarball($detail, $path);

    move $extracted_path, $installation_path;

    print "$installation_name is installed at $installation_path.\n";

    print "$installation_name is successfully installed.\n";
}

sub do_extract_skaji_relocatable_perl_tarball {
    my ($self, $detail, $tarball_path) = @_;

    my $workdir = $self->builddir
        ->child("skaji-relocatable-perl")
        ->child($detail->{version});

    $workdir->rmpath()
        if $workdir->exists();

    $workdir->mkpath();

    my $tarx = "tar xzf";
    my $extract_command = "cd $workdir; $tarx $tarball_path";

    system($extract_command) == 0
        or die "Failed to extract $tarball_path";

    my ($extracted_path) = $workdir->children;

    return $extracted_path;
}

sub do_install_program_from_url {
    my ( $self, $url, $program_name, $body_filter ) = @_;

    my $out = $self->root->bin($program_name);

    if ( -f $out && !$self->{force} && !$self->{yes} ) {
        require ExtUtils::MakeMaker;

        my $ans = ExtUtils::MakeMaker::prompt( "\n$out already exists, are you sure to override ? [y/N]", "N" );

        if ( $ans !~ /^Y/i ) {
            print "\n$program_name installation skipped.\n\n" unless $self->{quiet};
            return;
        }
    }

    my $body = http_get($url)
        or die "\nERROR: Failed to retrieve $program_name executable.\n\n";

    unless ( $body =~ m{\A#!/}s ) {
        my $x = App::Perlbrew::Path->new( $self->env('TMPDIR') || "/tmp", "${program_name}.downloaded.$$" );
        my $message =
"\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter.";

        unless ( -f $x ) {
            open my $OUT, ">", $x;
            print $OUT $body;
            close($OUT);
            $message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n";
        }

        die $message;
    }

    if ( $body_filter && ref($body_filter) eq "CODE" ) {
        $body = $body_filter->($body);
    }

    $self->root->bin->mkpath;
    open my $OUT, '>', $out or die "cannot open file($out): $!";
    print $OUT $body;
    close $OUT;