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
sub run_command_available {
my ($self) = @_;
my @installed = $self->installed_perls(@_);
my $is_verbose = $self->{verbose};
my @sections = ( ['perl', 'available_perl_distributions'] );
for (@sections) {
my ( $header, $method ) = @$_;
print "# $header\n";
my $perls = $self->$method;
# sort the keys of Perl installation (Randal to the rescue!)
my @sorted_perls = $self->sort_perl_versions( keys %$perls );
for my $available (@sorted_perls) {
my $url = $perls->{$available};
my $ctime;
for my $installed (@installed) {
my $name = $installed->{name};
my $cur = $installed->{is_current};
if ( $available eq $installed->{name} ) {
$ctime = $installed->{ctime};
last;
}
}
printf "%1s %12s %s %s\n", $ctime ? 'i' : '', $available,
(
$is_verbose
? $ctime
? "INSTALLED on $ctime via"
: 'available from '
: ''
),
( $is_verbose ? "<$url>" : '' );
}
print "\n\n";
}
return;
}
sub available_perls {
my ($self) = @_;
my %dists = ( %{ $self->available_perl_distributions } );
return $self->sort_perl_versions( keys %dists );
}
# -> Map[ NameVersion => URL ]
sub available_perl_distributions {
my ($self) = @_;
my $perls = {};
my @perllist;
# we got impatient waiting for cpan.org to get updated to show 5.28...
# So, we also fetch from metacpan for anything that looks perlish,
# and we do our own processing to filter out the development
# releases and minor versions when needed (using
# filter_perl_available)
my $json = http_get('https://fastapi.metacpan.org/v1/release/versions/perl')
or die "\nERROR: Unable to retrieve list of perls from Metacpan.\n\n";
my $decoded = decode_json($json);
for my $release ( @{ $decoded->{releases} } ) {
next
if !$release->{authorized};
push @perllist, [$release->{name}, $release->{download_url}];
}
foreach my $perl ( $self->filter_perl_available( \@perllist ) ) {
$perls->{ $perl->[0] } = $perl->[1];
}
return $perls;
}
# $perllist is an arrayref of arrayrefs. The inner arrayrefs are of the
# format: [ <perl_name>, <perl_url> ]
# perl_name = something like perl-5.28.0
# perl_url = URL the Perl is available from.
#
# If $self->{all} is true, this just returns a list of the contents of
# the list referenced by $perllist
#
# Otherwise, this looks for even middle numbers in the version and no
# suffix (like -RC1) following the URL, and returns the list of
# arrayrefs that so match
#
# If any "newest" Perl has a
sub filter_perl_available {
my ( $self, $perllist ) = @_;
if ( $self->{all} ) { return @$perllist; }
my %max_release;
foreach my $perl (@$perllist) {
my $ver = $perl->[0];
if ( $ver !~ m/^perl-5\.[0-9]*[02468]\.[0-9]+$/ ) { next; } # most likely TRIAL or RC, or a DEV release
my ( $release_line, $minor ) = $ver =~ m/^perl-5\.([0-9]+)\.([0-9]+)/;
if ( exists $max_release{$release_line} ) {
if ( $max_release{$release_line}->[0] > $minor ) { next; } # We have a newer release
}
$max_release{$release_line} = [$minor, $perl];
}
return map { $_->[1] } values %max_release;
}
sub perl_release {
my ( $self, $version ) = @_;
my $mirror = $self->cpan_mirror();
# try CPAN::Perl::Releases
my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
my $x = ( values %$tarballs )[0];
if ($x) {
my $dist_tarball = ( split( "/", $x ) )[-1];
my $dist_tarball_url = "$mirror/authors/id/$x";
return ( $dist_tarball, $dist_tarball_url );
}
# try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
my $index = http_get("https://cpan.metacpan.org/src/5.0/");
if ($index) {
for my $prefix ( "perl-", "perl" ) {
for my $suffix ( ".tar.bz2", ".tar.gz" ) {
my $dist_tarball = "$prefix$version$suffix";
my $dist_tarball_url = "$mirror/src/5.0/$dist_tarball";
return ( $dist_tarball, $dist_tarball_url )
if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms );
}
}
}
my $json = http_get("https://fastapi.metacpan.org/v1/release/_search?size=1&q=name:perl-${version}");
my $result;
unless ( $json and $result = decode_json($json)->{hits}{hits}[0] ) {
die "ERROR: Failed to locate perl-${version} tarball.";
}
my ( $dist_path, $dist_tarball ) =
lib/App/perlbrew.pm view on Meta::CPAN
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'} ) {
lib/App/perlbrew.pm view on Meta::CPAN
sub system_perl_shebang {
my ($self) = @_;
return $Config{sharpbang} . $self->system_perl_executable;
}
sub pristine_path {
my ($self) = @_;
return $self->purify("PATH");
}
sub pristine_manpath {
my ($self) = @_;
return $self->purify("MANPATH");
}
sub run_command_display_system_perl_executable {
print $_[0]->system_perl_executable . "\n";
}
sub run_command_display_system_perl_shebang {
print $_[0]->system_perl_shebang . "\n";
}
sub run_command_display_pristine_path {
print $_[0]->pristine_path . "\n";
}
sub run_command_display_pristine_manpath {
print $_[0]->pristine_manpath . "\n";
}
sub do_install_archive {
require File::Basename;
my $self = shift;
my $dist_tarball_path = shift;
my $dist_version;
my $installation_name;
if ( $dist_tarball_path->basename =~ m{(c?perl)-?(5.+)\.tar\.(gz|bz2|xz)\Z} ) {
my $perl_variant = $1;
$dist_version = $2;
$installation_name = "${perl_variant}-${dist_version}";
}
unless ( $dist_version && $installation_name ) {
die
"Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2 or perl-5.x.y.tar.xz\n";
}
my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
$self->do_install_this( $dist_extracted_path, $dist_version, $installation_name );
}
sub do_install_this {
my ( $self, $dist_extracted_dir, $dist_version, $installation_name ) = @_;
my $variation = $self->{variation};
my $append = $self->{append};
my $looks_like_we_are_installing_cperl = $dist_extracted_dir =~ /\/ cperl- /x;
$self->{dist_extracted_dir} = $dist_extracted_dir;
$self->{log_file} = $self->root->child("build.${installation_name}${variation}${append}.log");
my @d_options = @{ $self->{D} };
my @u_options = @{ $self->{U} };
my @a_options = @{ $self->{A} };
my $sitecustomize = $self->{sitecustomize};
my $destdir = $self->{destdir};
$installation_name = $self->{as} if $self->{as};
$installation_name .= "$variation$append";
$self->{installation_name} = $installation_name;
if ($sitecustomize) {
die "Could not read sitecustomize file '$sitecustomize'\n"
unless -r $sitecustomize;
push @d_options, "usesitecustomize";
}
if ( $self->{noman} ) {
push @d_options, qw/man1dir=none man3dir=none/;
}
for my $flavor ( keys %flavor ) {
$self->{$flavor} and push @d_options, $flavor{$flavor}{d_option};
}
my $perlpath = $self->root->perls($installation_name);
unshift @d_options, qq(prefix=$perlpath);
push @d_options, "usedevel" if $dist_version =~ /5\.\d[13579]|git|blead/;
push @d_options, "usecperl" if $looks_like_we_are_installing_cperl;
my $version = $self->comparable_perl_version($dist_version);
if ( defined $version and $version < $self->comparable_perl_version('5.6.0') ) {
# ancient perls do not support -A for Configure
@a_options = ();
}
else {
unless ( grep { /eval:scriptdir=/ } @a_options ) {
push @a_options, "'eval:scriptdir=${perlpath}/bin'";
}
}
print "Installing $dist_extracted_dir into "
. $self->root->perls($installation_name)->stringify_with_tilde . "\n\n";
print <<INSTALL if !$self->{verbose};
This could take a while. You can run the following command on another shell to track the status:
tail -f ${\ $self->{log_file}->stringify_with_tilde }
INSTALL
my @preconfigure_commands = ( "cd $dist_extracted_dir", "rm -f config.sh Policy.sh", );
if ((not $self->{"no-patchperl"})
&& (not $looks_like_we_are_installing_cperl)
&& (my $patchperl = maybe_patchperl($self->root))) {
push @preconfigure_commands, 'chmod -R +w .', $patchperl;
}
my $configure_flags = $self->env("PERLBREW_CONFIGURE_FLAGS") || '-de';
my @configure_commands = (
"sh Configure $configure_flags "
. join( ' ',
( map { qq{'-D$_'} } @d_options ),
( map { qq{'-U$_'} } @u_options ),
( map { qq{'-A$_'} } @a_options ),
),
( defined $version and $version < $self->comparable_perl_version('5.8.9') )
? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile")
: ()
);
my $make = $ENV{MAKE} || ( $^O eq "solaris" ? 'gmake' : 'make' );
my @build_commands = ( $make . ' ' . ( $self->{j} ? "-j$self->{j}" : "" ) );
# 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 $use_harness = ( $dist_version =~ /^5\.(\d+)\.(\d+)/
&& ( $1 >= 8 || $1 == 7 && $2 == 3 ) )
|| $dist_version eq "blead";
my $test_target = $use_harness ? "test_harness" : "test";
local $ENV{TEST_JOBS} = $self->{j}
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 #####') };
( run in 3.334 seconds using v1.01-cache-2.11-cpan-5837b0d9d2c )