@@ -2,20 +2,27 @@ package App::perlbrew;
use strict;
use warnings;
use 5.008;
-our $VERSION = "0.59";
-
+our $VERSION = "0.67";
use Config;
-use Capture::Tiny;
+
+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 List::Util qw/min/;
use Getopt::Long ();
-use File::Spec::Functions qw( catfile catdir );
-use File::Basename;
-use File::Path ();
-use FindBin;
-use CPAN::Perl::Releases;
-our $CONFIG;
-our $PERLBREW_ROOT = $ENV{PERLBREW_ROOT} || catdir($ENV{HOME}, "perl5", "perlbrew");
-our $PERLBREW_HOME = $ENV{PERLBREW_HOME} || catdir($ENV{HOME}, ".perlbrew");
+### global variables
local $SIG{__DIE__} = sub {
my $message = shift;
@@ -23,31 +30,146 @@ local $SIG{__DIE__} = sub {
exit(1);
};
+our $CONFIG;
+our $PERLBREW_ROOT = $ENV{PERLBREW_ROOT} || joinpath($ENV{HOME}, "perl5", "perlbrew");
+our $PERLBREW_HOME = $ENV{PERLBREW_HOME} || joinpath($ENV{HOME}, ".perlbrew");
+
+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' },
+
+ { d_option => 'cc=clang',
+ opt => 'clang' },
+ );
+
+
+my %flavor;
+my $flavor_ix = 0;
+for (@flavors) {
+ my ($name) = $_->{opt} =~ /([^|]+)/;
+ $_->{name} = $name;
+ $_->{ix} = ++$flavor_ix;
+ $flavor{$name} = $_;
+}
+for (@flavors) {
+ if (my $implies = $_->{implies}) {
+ $flavor{$implies}{implied_by} = $_->{name};
+ }
+}
+
+### functions
+
+sub joinpath { join "/", @_ }
+
sub mkpath {
+ require File::Path;
File::Path::mkpath([@_], 0, 0777);
}
sub rmpath {
- File::Path::rmtree([@_], 0, 1);
+ require File::Path;
+ File::Path::rmtree([@_], 0, 0);
}
-sub uniq(@) {
- my %a;
- grep { ++$a{$_} == 1 } @_;
-}
+sub files_are_the_same {
+ ## Check dev and inode num. Not useful on Win32.
+ ## The for loop should always return false on Win32, as a result.
+
+ my @files = @_;
+ my @stats = map {[ stat($_) ]} @files;
-sub min(@) {
- my @a = @_;
- my $m = $a[0];
- for my $x (@a) {
- $m = $x if $x < $m
+ my $stats0 = join " ", @{$stats[0]}[0,1];
+ for (@stats) {
+ return 0 if ((! defined($_->[1])) || $_->[1] == 0);
+ unless ($stats0 eq join(" ", $_->[0], $_->[1])) {
+ return 0;
+ }
}
- return $m;
+ return 1
}
-
{
- my @command;
+ my %commands = (
+ curl => {
+ test => '--version >/dev/null 2>&1',
+ get => '--silent --location --fail -o - {url}',
+ download => '--silent --location --fail -o {output} {url}'
+ },
+ wget => {
+ test => '--version >/dev/null 2>&1',
+ get => '--quiet -O - {url}',
+ download => '--quiet -O {output} {url}',
+ },
+ fetch => {
+ test => '--version >/dev/null 2>&1',
+ get => '-o - {url}',
+ download => '{url}'
+ }
+ );
+
+ sub http_user_agent_program {
+ my $program;
+ for my $p (keys %commands) {
+ my $code = system("$p $commands{$p}->{test}") >> 8;
+ if ($code != 127) {
+ $program = $p;
+ last;
+ }
+ }
+
+ unless($program) {
+ die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n";
+ }
+
+ return $program;
+ }
+
+ sub http_user_agent_command {
+ my ($purpose, $params) = @_;
+ my $ua = http_user_agent_program;
+ my $cmd = $ua . " " . $commands{ $ua }->{ $purpose };
+ for (keys %$params) {
+ $cmd =~ s!{$_}!$params->{$_}!g;
+ }
+ return ($ua, $cmd) if wantarray;
+ return $cmd;
+ }
+
+ sub http_download {
+ my ($url, $path) = @_;
+
+ if (-e $path) {
+ die "ERROR: The download target < $path > already exists.\n";
+ }
+
+ my $download_command = http_user_agent_command( download => { url => $url, output => $path } );
+
+ my $status = system($download_command);
+ unless ($status == 0) {
+ return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$?";
+ }
+ return 0;
+ }
+
sub http_get {
my ($url, $header, $cb) = @_;
@@ -56,39 +178,23 @@ sub min(@) {
$header = undef;
}
- if (! @command) {
- my @commands = (
- # curl's --fail option makes the exit code meaningful
- [qw( curl --silent --location --fail --insecure )],
- [qw( fetch -o - )],
- [qw( wget --no-check-certificate --quiet -O - )],
- );
- for my $command (@commands) {
- my $program = $command->[0];
- my $code = system("$program --version >/dev/null 2>&1") >> 8;
- if ($code != 127) {
- @command = @$command;
- last;
- }
- }
- die "You have to install either curl or wget\n"
- unless @command;
- }
+ my ($program, $command) = http_user_agent_command( get => { url => $url } );
- open my $fh, '-|', @command, $url
- or die "open() for '@command $url': $!";
+ open my $fh, '-|', $command
+ or die "open() for '$command': $!";
local $/;
my $body = <$fh>;
close $fh;
+
die 'Page not retrieved; HTTP error code 400 or above.'
- if $command[0] eq 'curl' # Exit code is 22 on 404s etc
+ if $program eq 'curl' # Exit code is 22 on 404s etc
and $? >> 8 == 22; # exit code is packed into $?; see perlvar
die 'Page not retrieved: fetch failed.'
- if $command[0] eq 'fetch' # Exit code is not 0 on error
+ if $program eq 'fetch' # Exit code is not 0 on error
and $?;
die 'Server issued an error response.'
- if $command[0] eq 'wget' # Exit code is 8 on 404s etc
+ if $program eq 'wget' # Exit code is 8 on 404s etc
and $? >> 8 == 8;
return $cb ? $cb->($body) : $body;
@@ -98,6 +204,7 @@ sub min(@) {
sub perl_version_to_integer {
my $version = shift;
my @v = split(/[\.\-_]/, $version);
+ return undef if @v < 2;
if ($v[1] <= 5) {
$v[2] ||= 0;
$v[3] = 0;
@@ -110,74 +217,116 @@ sub perl_version_to_integer {
return $v[1]*1000000 + $v[2]*1000 + $v[3];
}
-sub parse_cmdline {
- my ($self, $params, @ext) = @_;
-
- Getopt::Long::GetOptions(
- $params,
-
- 'force|f!',
- 'notest|n!',
- 'quiet|q!',
- 'verbose|v',
- 'as=s',
- 'help|h',
- 'version',
- 'root=s',
- 'switch',
+# straight copy of Wikipedia's "Levenshtein Distance"
+sub editdist {
+ my @a = split //, shift;
+ my @b = split //, shift;
- # options passed directly to Configure
- 'D=s@',
- 'U=s@',
- 'A=s@',
+ # There is an extra row and column in the matrix. This is the
+ # distance from the empty string to a substring of the target.
+ my @d;
+ $d[$_][0] = $_ for (0 .. @a);
+ $d[0][$_] = $_ for (0 .. @b);
- 'j=i',
- # options that affect Configure and customize post-build
- 'sitecustomize=s',
+ for my $i (1 .. @a) {
+ for my $j (1 .. @b) {
+ $d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1]
+ : 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1]));
+ }
+ }
- @ext
- )
- or run_command_help(1);
+ return $d[@a][@b];
}
+### methods
+
sub new {
my($class, @argv) = @_;
my %opt = (
original_argv => \@argv,
+ args => [],
force => 0,
quiet => 0,
D => [],
U => [],
A => [],
sitecustomize => '',
+ noman => '',
+ variation => '',
+ both => [],
+ append => '',
);
- # build a local @ARGV to allow us to use an older
- # Getopt::Long API in case we are building on an older system
- local (@ARGV) = @argv;
+ $opt{$_} = '' for keys %flavor;
- Getopt::Long::Configure(
- 'pass_through',
- 'no_ignore_case',
- 'bundling',
- 'permute', # default behaviour except 'exec'
- );
+ if (@argv) {
+ # build a local @ARGV to allow us to use an older
+ # Getopt::Long API in case we are building on an older system
+ local (@ARGV) = @argv;
+
+ Getopt::Long::Configure(
+ 'pass_through',
+ 'no_ignore_case',
+ 'bundling',
+ 'permute', # default behaviour except 'exec'
+ );
- $class->parse_cmdline (\%opt);
+ $class->parse_cmdline(\%opt);
- $opt{args} = \@ARGV;
+ $opt{args} = \@ARGV;
- # fix up the effect of 'bundling'
- foreach my $flags (@opt{qw(D U A)}) {
- foreach my $value(@{$flags}) {
- $value =~ s/^=//;
+ # fix up the effect of 'bundling'
+ foreach my $flags (@opt{qw(D U A)}) {
+ foreach my $value (@{$flags}) {
+ $value =~ s/^=//;
+ }
}
}
return bless \%opt, $class;
}
+sub parse_cmdline {
+ my ($self, $params, @ext) = @_;
+
+ my @f = map { $flavor{$_}{opt} || $_ } keys %flavor;
+
+ return Getopt::Long::GetOptions(
+ $params,
+
+ 'force|f!',
+ 'notest|n!',
+ 'quiet|q!',
+ 'verbose|v',
+ 'as=s',
+ 'append=s',
+ 'help|h',
+ 'version',
+ 'root=s',
+ 'switch',
+ 'all',
+
+ # options passed directly to Configure
+ 'D=s@',
+ 'U=s@',
+ 'A=s@',
+
+ 'j=i',
+ # options that affect Configure and customize post-build
+ 'sitecustomize=s',
+ 'noman',
+
+ # flavors support
+ 'both|b=s@',
+ 'all-variations',
+ 'common-variations',
+ @f,
+
+ @ext
+ )
+}
+
sub root {
my ($self, $new_root) = @_;
@@ -200,22 +349,47 @@ sub current_lib {
return $self->{current_lib} || $self->env('PERLBREW_LIB') || '';
}
-sub current_perl_executable {
+sub current_env {
my ($self) = @_;
- return $self->installed_perl_executable($self->current_perl);
+ my $l = $self->current_lib;
+ $l = "@" . $l if $l;
+ return $self->current_perl . $l;
}
sub installed_perl_executable {
my ($self, $name) = @_;
- my $executable = catfile($self->root, "perls", $name, "bin", "perl");
+ die unless $name;
+
+ my $executable = joinpath($self->root, "perls", $name, "bin", "perl");
return $executable if -e $executable;
return "";
}
+sub configure_args {
+ my ($self, $name) = @_;
+
+ my $perl_cmd = $self->installed_perl_executable( $name );
+ my $code = 'while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}';
+
+ my @output = split "\n" => $self->do_capture($perl_cmd, '-MConfig', '-wle', $code);
+
+ my %arg;
+ for(@output) {
+ my ($k,$v) = split " ", $_, 2;
+ $arg{$k} = $v;
+ }
+
+ if (wantarray) {
+ return map { $arg{"config_arg$_"} } (1 .. $arg{config_argc})
+ }
+
+ return $arg{config_args}
+}
+
sub cpan_mirror {
my ($self, $v) = @_;
unless($self->{cpan_mirror}) {
- $self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "http://search.cpan.org/CPAN";
+ $self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "http://www.cpan.org";
$self->{cpan_mirror} =~ s{/+$}{};
}
return $self->{cpan_mirror};
@@ -275,27 +449,6 @@ sub commands {
return @commands;
}
-# straight copy of Wikipedia's "Levenshtein Distance"
-sub editdist {
- my @a = split //, shift;
- my @b = split //, shift;
-
- # There is an extra row and column in the matrix. This is the
- # distance from the empty string to a substring of the target.
- my @d;
- $d[$_][0] = $_ for (0 .. @a);
- $d[0][$_] = $_ for (0 .. @b);
-
- for my $i (1 .. @a) {
- for my $j (1 .. @b) {
- $d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1]
- : 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1]));
- }
- }
-
- return $d[@a][@b];
-}
-
sub find_similar_commands {
my ( $self, $command ) = @_;
my $SIMILAR_DISTANCE = 6;
@@ -318,37 +471,6 @@ sub find_similar_commands {
return @commands;
}
-sub download {
- my ($self, $url, $path, $on_error) = @_;
-
- my $mirror = $self->config->{mirror};
- my $header = $mirror ? { 'Cookie' => "cpan=$mirror->{url}" } : undef;
-
- open my $BALL, ">", $path or die "Failed to open $path for writing.\n";
-
- http_get(
- $url,
- $header,
- sub {
- my ($body) = @_;
-
- unless ($body) {
- if (ref($on_error) eq 'CODE') {
- $on_error->($url);
- }
- else {
- die "ERROR: Failed to download $url.\n"
- }
- }
-
-
- print $BALL $body;
- }
- );
-
- close $BALL;
-}
-
sub run_command {
my ( $self, $x, @args ) = @_;
my $command = $x;
@@ -383,12 +505,6 @@ sub run_command {
}
}
- if ($x eq 'install') {
- # prepend "perl-" to version number, but only if there is an argument
- $args[0] =~ s/\A((?:\d+\.)*\d+)\Z/perl-$1/
- if @args;
- }
-
$self->$s(@args);
}
@@ -518,7 +634,9 @@ sub run_command_available {
sub available_perls {
my ( $self, $dist, $opts ) = @_;
- my $url = "http://www.cpan.org/src/README.html";
+ my $url = $self->{all} ? "http://www.cpan.org/src/5.0/"
+ : "http://www.cpan.org/src/README.html" ;
+
my $html = http_get( $url, undef, undef );
unless($html) {
@@ -528,8 +646,14 @@ sub available_perls {
my @available_versions;
for ( split "\n", $html ) {
- push @available_versions, $1
- if m|<td><a href="http://www.cpan.org/src/.+?">(.+?)</a></td>|;
+ if ( $self->{all} ) {
+ push @available_versions, $1
+ if m|<a href="perl.*?\.tar\.gz">(.+?)</a>|;
+ }
+ else {
+ push @available_versions, $1
+ if m|<td><a href="http://www.cpan.org/src/.+?">(.+?)</a></td>|;
+ }
}
s/\.tar\.gz// for @available_versions;
@@ -539,6 +663,21 @@ sub available_perls {
sub perl_release {
my ($self, $version) = @_;
+ # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz
+ my $index = http_get("http://www.cpan.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 = $self->cpan_mirror() . "/src/5.0/$dist_tarball";
+ return ( $dist_tarball, $dist_tarball_url )
+ if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms );
+ }
+ }
+ }
+
+ # try CPAN::Perl::Releases
+ require CPAN::Perl::Releases;
my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
my $x = (values %$tarballs)[0];
@@ -549,12 +688,13 @@ sub perl_release {
return ($dist_tarball, $dist_tarball_url);
}
+ # try to find it on search.cpan.org
my $mirror = $self->config->{mirror};
my $header = $mirror ? { 'Cookie' => "cpan=$mirror->{url}" } : undef;
my $html = http_get("http://search.cpan.org/dist/perl-${version}", $header);
unless ($html) {
- die "ERROR: Failed to download perl-${version} tarball.";
+ die "ERROR: Failed to locate perl-${version} tarball.";
}
my ($dist_path, $dist_tarball) =
@@ -578,11 +718,11 @@ sub run_command_init {
exit 0;
}
- mkpath($_) for (grep { ! -d $_ } map { catdir($self->root, $_) } qw(perls dists build etc bin));
+ mkpath($_) for (grep { ! -d $_ } map { joinpath($self->root, $_) } qw(perls dists build etc bin));
my ($f, $fh) = @_;
- my $etc_dir = catdir($self->root, "etc");
+ my $etc_dir = joinpath($self->root, "etc");
for (["bashrc", "BASHRC_CONTENT"],
["cshrc", "CSHRC_CONTENT"],
@@ -590,9 +730,10 @@ sub run_command_init {
["csh_wrapper", "CSH_WRAPPER_CONTENT"],
["csh_set_path", "CSH_SET_PATH_CONTENT"],
["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"],
+ ["perlbrew.fish", "PERLBREW_FISH_CONTENT" ],
) {
my ($file_name, $method) = @$_;
- my $path = catfile($etc_dir, $file_name);
+ my $path = joinpath($etc_dir, $file_name);
if (! -f $path) {
open($fh, ">", $path) or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again.";
print $fh $self->$method;
@@ -619,6 +760,10 @@ sub run_command_init {
$shrc = "bashrc";
$yourshrc = 'zshenv';
}
+ elsif( $self->env('SHELL') =~ m/fish/ ) {
+ $shrc = "perlbrew.fish";
+ $yourshrc = 'config/fish/config.fish';
+ }
else {
$shrc = "bashrc";
$yourshrc = "bash_profile";
@@ -628,10 +773,15 @@ sub run_command_init {
my $pb_home_dir = $self->path_with_tilde($PERLBREW_HOME);
my $code = qq( source $root_dir/etc/${shrc});
- if ($PERLBREW_HOME ne catdir($ENV{HOME}, ".perlbrew")) {
+ if ($PERLBREW_HOME ne joinpath($ENV{HOME}, ".perlbrew")) {
$code = " export PERLBREW_HOME=$pb_home_dir\n" . $code;
}
+ if ( $self->env('SHELL') =~ m/fish/ ) {
+ $code =~ s/source/./;
+ $code =~ s/export (\S+)=(\S+)/set -x $1 $2/;
+ }
+
print <<INSTRUCTION;
perlbrew root ($root_dir) is initialized.
@@ -657,18 +807,14 @@ sub run_command_self_install {
my $self = shift;
my $executable = $0;
+ my $target = joinpath($self->root, "bin", "perlbrew");
- unless (File::Spec->file_name_is_absolute($executable)) {
- $executable = File::Spec->rel2abs($executable);
- }
-
- my $target = catfile($self->root, "bin", "perlbrew");
- if ($executable eq $target) {
+ if (files_are_the_same($executable, $target)) {
print "You are already running the installed perlbrew:\n\n $executable\n";
exit;
}
- mkpath( catdir($self->root, "bin" ));
+ mkpath( joinpath($self->root, "bin" ));
open my $fh, "<", $executable;
my @lines = <$fh>;
@@ -697,15 +843,20 @@ sub do_install_git {
my $dist_name;
my $dist_git_describe;
my $dist_version;
- require Cwd;
- my $cwd = Cwd::cwd();
+
+ opendir my $cwd_orig, ".";
+
chdir $dist;
+
if (`git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/) {
$dist_name = 'perl';
$dist_git_describe = "v$1";
$dist_version = $2;
}
- chdir $cwd;
+
+ chdir $cwd_orig;
+
+ require File::Spec;
my $dist_extracted_dir = File::Spec->rel2abs( $dist );
$self->do_install_this($dist_extracted_dir, $dist_version, "$dist_name-$dist_version");
return;
@@ -720,7 +871,7 @@ sub do_install_url {
my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;
my ($dist_tarball) = $dist =~ m{/([^/]*)$};
- my $dist_tarball_path = catfile($self->root, "dists", $dist_tarball);
+ my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball);
my $dist_tarball_url = $dist;
$dist = "$dist_name-$dist_version"; # we install it as this name later
@@ -731,7 +882,8 @@ sub do_install_url {
}
else {
print "Fetching $dist as $dist_tarball_path\n";
- $self->download($dist_tarball_url, $dist_tarball_path);
+ my $error = http_download($dist_tarball_url, $dist_tarball_path);
+ die "ERROR: Failed to download $dist_tarball_url\n" if $error;
}
my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path);
@@ -743,15 +895,26 @@ sub do_extract_tarball {
my $self = shift;
my $dist_tarball = shift;
+ # Assuming the dir extracted from the tarball is named after the tarball.
+ my $dist_tarball_basename = $dist_tarball;
+ $dist_tarball_basename =~ s{.*/([^/]+)\.tar\.(?:gz|bz2)$}{$1};
+
+ # Note that this is incorrect for blead.
+ my $extracted_dir = "@{[ $self->root ]}/build/$dist_tarball_basename";
+
# Was broken on Solaris, where GNU tar is probably
# installed as 'gtar' - RT #61042
my $tarx =
($^O eq 'solaris' ? 'gtar ' : 'tar ') .
( $dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf' );
+
+ if (-d $extracted_dir) {
+ rmpath($extracted_dir);
+ }
+
my $extract_command = "cd @{[ $self->root ]}/build; $tarx $dist_tarball";
die "Failed to extract $dist_tarball" if system($extract_command);
- $dist_tarball =~ s{.*/([^/]+)\.tar\.(?:gz|bz2)$}{$1};
- return "@{[ $self->root ]}/build/$dist_tarball"; # Note that this is incorrect for blead
+ return $extracted_dir;
}
sub do_install_blead {
@@ -765,21 +928,19 @@ sub do_install_blead {
# We always blindly overwrite anything that's already there,
# because blead is a moving target.
my $dist_tarball = 'blead.tar.gz';
- my $dist_tarball_path = catfile($self->root, "dists", $dist_tarball);
+ my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball);
print "Fetching $dist_git_describe as $dist_tarball_path\n";
- $self->download(
- "http://perl5.git.perl.org/perl.git/snapshot/$dist_tarball", $dist_tarball_path,
- sub {
- die "\nERROR: Failed to download perl-blead tarball.\n\n";
- }
- );
+ my $error = http_download("http://perl5.git.perl.org/perl.git/snapshot/$dist_tarball", $dist_tarball_path);
+ if ($error) {
+ die "\nERROR: Failed to download perl-blead tarball.\n\n";
+ }
# Returns the wrong extracted dir for blead
$self->do_extract_tarball($dist_tarball_path);
- my $build_dir = catdir($self->root, "build");
+ my $build_dir = joinpath($self->root, "build");
local *DIRH;
opendir DIRH, $build_dir or die "Couldn't open ${build_dir}: $!";
my @contents = readdir DIRH;
@@ -790,13 +951,13 @@ sub do_install_blead {
# so we stat each one only once.
@candidates = map { $_->[0] }
sort { $b->[1] <=> $a->[1] } # descending
- map { [ $_, (stat( catdir($build_dir, $_) ))[9] ] } @candidates;
- my $dist_extracted_dir = catdir($self->root, "build", $candidates[0]); # take the newest one
+ map { [ $_, (stat( joinpath($build_dir, $_) ))[9] ] } @candidates;
+ my $dist_extracted_dir = joinpath($self->root, "build", $candidates[0]); # take the newest one
$self->do_install_this($dist_extracted_dir, $dist_version, "$dist_name-$dist_version");
return;
}
-sub resolve_stable {
+sub resolve_stable_version {
my ($self) = @_;
my ($latest_ver, $latest_minor);
@@ -811,22 +972,22 @@ sub resolve_stable {
die "Can't determine latest stable Perl release\n"
if !defined $latest_ver;
- return "perl-$latest_ver";
+ return $latest_ver;
}
sub do_install_release {
- my ($self, $dist, $dist_name, $dist_version) = @_;
+ my ($self, $dist, $dist_version) = @_;
my ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version);
- my $dist_tarball_path = catfile($self->root, "dists", $dist_tarball);
+ my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball);
if (-f $dist_tarball_path) {
print "Use the previously fetched ${dist_tarball}\n"
if $self->{verbose};
}
else {
- print "Fetching $dist_name $dist_version as $dist_tarball_path\n" unless $self->{quiet};
- $self->download( $dist_tarball_url, $dist_tarball_path );
+ 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);
@@ -842,46 +1003,148 @@ sub run_command_install {
exit(-1);
}
- $dist = $self->resolve_stable if $dist =~ m/^(?:perl-?)?stable$/;
-
- $self->{dist_name} = $dist;
+ $self->{dist_name} = $dist; # for help msg generation, set to non
+ # normalized name
- my $installation_name = $self->{as} || $dist;
- if ($self->is_installed( $installation_name ) && !$self->{force}) {
- die "\nABORT: $installation_name is already installed.\n\n";
- }
-
- my $help_message = "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` for the instruction on using the install command.\n\n";
+ if ($dist =~ /^(?:perl-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/) {
+ my $version = ($1 eq 'stable' ? $self->resolve_stable_version : $1);
+ $dist = "perl-$version"; # normalize dist name
- my ($dist_name, $dist_version) = $dist =~ m/^(perl)-?([\d._]+(?:-RC\d+)?|git)$/;
- if (!$dist_name || !$dist_version) { # some kind of special install
- if (-d "$dist/.git") {
- $self->do_install_git($dist);
- }
- if (-f $dist) {
- $self->do_install_archive($dist);
+ 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";
}
- elsif ($dist =~ m/^(?:https?|ftp|file)/) { # more protocols needed?
- $self->do_install_url($dist);
- }
- elsif ($dist =~ m/(?:perl-)?blead$/) {
+
+ if ($version eq 'blead') {
$self->do_install_blead($dist);
}
else {
- die $help_message;
+ $self->do_install_release( $dist, $version );
}
+
}
- elsif ($dist_name eq 'perl') {
- $self->do_install_release( $dist, $dist_name, $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($dist);
+ }
+ elsif ($dist =~ m/^(?:https?|ftp|file)/) { # more protocols needed?
+ $self->do_install_url($dist);
}
else {
- die $help_message;
+ 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;
+ }
+ elsif ($self->{'common-variations'}) {
+ push @both, grep $flavor{$_}{common}, keys %flavor;
+ }
+
+ # check the validity of the varitions given via 'both'
+ for my $both (@both) {
+ $flavor{$both} or die "$both is not a supported flavor.\n\n";
+ $self->{$both} and die "options --both $both and --$both can not be used together";
+ if (my $implied_by = $flavor{$both}{implied_by}) {
+ $self->{$implied_by} and die "options --both $both and --$implied_by can not be used together";
+ }
+ }
+
+ # flavors selected always
+ my $start = '';
+ $start .= "-$_" for grep $self->{$_}, keys %flavor;
+
+ # make variations
+ my @var = $start;
+ for my $both (@both) {
+ my $append = join('-', $both, grep defined, $flavor{$both}{implies});
+ push @var, map "$_-$append", @var;
}
- $self->switch_to($installation_name)
+ # normalize the variation names
+ @var = map { join '-', '', sort { $flavor{$a}{ix} <=> $flavor{$b}{ix} } grep length, split /-+/, $_ } @var;
+ s/(\b\w+\b)(?:-\1)+/$1/g for @var; # remove duplicate flavors
+
+ # After inspecting perl Configure script this seems to be the most
+ # reliable heuristic to determine if perl would have 64bit IVs by
+ # default or not:
+ if ($Config::Config{longsize} >= 8) {
+ # We are in a 64bit platform. 64int and 64all are always set but
+ # we don't want them to appear on the final perl name
+ s/-64\w+//g for @var;
+ }
+
+ # remove duplicated variations
+ my %var = map { $_ => 1 } @var;
+ sort keys %var;
+}
+
+sub run_command_install_multiple {
+ my ( $self, @dists) = @_;
+
+ unless(@dists) {
+ $self->run_command_help("install-multiple");
+ exit(-1);
+ }
+
+ die "--switch can not be used with command install-multiple.\n\n"
if $self->{switch};
+ die "--as can not be used when more than one distribution is given.\n\n"
+ if $self->{as} and @dists > 1;
+
+ my @variations = $self->check_and_calculate_variations;
+ print join("\n",
+ "Compiling the following distributions:",
+ map(" $_$self->{append}", @dists),
+ " with the following variations:",
+ map((/-(.*)/ ? " $1" : " default"), @variations),
+ "", "");
+
+ my @ok;
+ for my $dist (@dists) {
+ for my $variation (@variations) {
+ local $@;
+ eval {
+ $self->{$_} = '' for keys %flavor;
+ $self->{$_} = 1 for split /-/, $variation;
+ $self->{variation} = $variation;
+ $self->{installation_name} = undef;
+
+ $self->run_command_install($dist);
+ push @ok, $self->{installation_name};
+ };
+ if ($@) {
+ $@ =~ s/\n+$/\n/;
+ print "Installation of $dist$variation failed: $@";
+ }
+ }
+ }
- return;
+ print join("\n",
+ "",
+ "The following perls have been installed:",
+ map (" $_", grep defined, @ok),
+ "", "");
+ return
}
sub run_command_download {
@@ -892,14 +1155,17 @@ sub run_command_download {
die "\"$dist\" does not look like a perl distribution name. " unless $dist_version =~ /^\d\./;
my ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version);
- my $dist_tarball_path = catfile($self->root, "dists", $dist_tarball);
+ my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball);
if (-f $dist_tarball_path && !$self->{force}) {
print "$dist_tarball already exists\n";
}
else {
print "Download $dist_tarball_url to $dist_tarball_path\n" unless $self->{quiet};
- $self->download( $dist_tarball_url, $dist_tarball_path );
+ my $error = http_download($dist_tarball_url, $dist_tarball_path);
+ if ($error) {
+ die "ERROR: Failed to download $dist_tarball_url\n";
+ }
}
}
@@ -952,12 +1218,14 @@ sub run_command_display_pristine_manpath {
}
sub do_install_archive {
+ require File::Basename;
+
my $self = shift;
my $dist_tarball_path = shift;
my $dist_version;
my $installation_name;
- if (basename($dist_tarball_path) =~ m{perl-?(5.+)\.tar\.(gz|bz2)\Z}) {
+ if (File::Basename::basename($dist_tarball_path) =~ m{perl-?(5.+)\.tar\.(gz|bz2)\Z}) {
$dist_version = $1;
$installation_name = "perl-${dist_version}";
}
@@ -973,16 +1241,21 @@ sub do_install_archive {
sub do_install_this {
my ($self, $dist_extracted_dir, $dist_version, $installation_name) = @_;
- $self->{dist_extracted_dir} = $dist_extracted_dir;
- $self->{log_file} ||= catfile($self->root, "build.${installation_name}.log");
- my $version = perl_version_to_integer($dist_version);
+ my $variation = $self->{variation};
+ my $append = $self->{append};
+
+ $self->{dist_extracted_dir} = $dist_extracted_dir;
+ $self->{log_file} = joinpath($self->root, "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};
$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"
@@ -990,6 +1263,14 @@ sub do_install_this {
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";
my $patchperl = $self->root . "/bin/patchperl";
@@ -1004,7 +1285,8 @@ sub do_install_this {
push @a_options, "'eval:scriptdir=${perlpath}/bin'";
}
- if ( $version < perl_version_to_integer( '5.6.0' ) ) {
+ my $version = perl_version_to_integer($dist_version);
+ if (defined $version and $version < perl_version_to_integer( '5.6.0' ) ) {
# ancient perls do not support -A for Configure
@a_options = ();
}
@@ -1032,7 +1314,7 @@ INSTALL
( map { qq{'-U$_'} } @u_options ),
( map { qq{'-A$_'} } @a_options ),
),
- $version < perl_version_to_integer( '5.8.9' )
+ (defined $version and $version < perl_version_to_integer( '5.8.9' ))
? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile")
: ()
);
@@ -1076,7 +1358,7 @@ INSTALL
delete $ENV{$_} for qw(PERL5LIB PERL5OPT);
if ($self->do_system($cmd)) {
- my $newperl = catfile($self->root, "perls", $installation_name, "bin", "perl");
+ my $newperl = joinpath($self->root, "perls", $installation_name, "bin", "perl");
unless (-e $newperl) {
$self->run_command_symlink_executables($installation_name);
}
@@ -1117,6 +1399,20 @@ sub do_install_program_from_url {
my $body = http_get($url) or die "\nERROR: Failed to retrieve $program_name executable.\n\n";
+ unless ($body =~ m{\A#!/}s) {
+ my $x = joinpath($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);
}
@@ -1129,16 +1425,27 @@ sub do_install_program_from_url {
print "\n$program_name is installed to\n\n $out\n\n" unless $self->{quiet};
}
+sub do_exit_with_error_code {
+ my ($self, $code) = @_;
+ exit($code);
+}
+
+sub do_system_with_exit_code {
+ my ($self, @cmd) = @_;
+ return system(@cmd);
+}
+
sub do_system {
my ($self, @cmd) = @_;
- return ! system(@cmd);
+ return ! $self->do_system_with_exit_code(@cmd);
}
sub do_capture {
- my ($self, $cmd) = @_;
- return Capture::Tiny::capture {
- $self->do_system($cmd);
- };
+ my ($self, @cmd) = @_;
+ require Capture::Tiny;
+ return Capture::Tiny::capture( sub {
+ $self->do_system(@cmd);
+ });
}
sub format_perl_version {
@@ -1159,18 +1466,20 @@ sub installed_perls {
for (<$root/perls/*>) {
my ($name) = $_ =~ m/\/([^\/]+$)/;
- my $executable = catfile($_, 'bin', 'perl');
+ my $executable = joinpath($_, 'bin', 'perl');
+ my $orig_version = `$executable -e 'print \$]'`;
push @result, {
name => $name,
- version => $self->format_perl_version(`$executable -e 'print \$]'`),
+ orig_version=> $orig_version,
+ version => $self->format_perl_version($orig_version),
is_current => ($self->current_perl eq $name) && !$self->env("PERLBREW_LIB"),
libs => [ $self->local_libs($name) ],
executable => $executable
};
}
- return @result;
+ return sort { $a->{orig_version} <=> $b->{orig_version} or $a->{name} cmp $b->{name} } @result;
}
sub local_libs {
@@ -1203,6 +1512,12 @@ sub is_installed {
return grep { $name eq $_->{name} } $self->installed_perls;
}
+sub assert_known_installation {
+ my ($self, $name) = @_;
+ return 1 if $self->is_installed($name);
+ die "ERROR: The installation \"$name\" is unknown\n\n";
+}
+
# Return a hash of PERLBREW_* variables
sub perlbrew_env {
my ($self, $name) = @_;
@@ -1218,7 +1533,7 @@ sub perlbrew_env {
my %env = (
PERLBREW_VERSION => $VERSION,
- PERLBREW_PATH => catdir($self->root, "bin"),
+ PERLBREW_PATH => joinpath($self->root, "bin"),
PERLBREW_MANPATH => "",
PERLBREW_ROOT => $self->root
);
@@ -1226,13 +1541,12 @@ sub perlbrew_env {
if ($perl_name) {
if(-d "@{[ $self->root ]}/perls/$perl_name/bin") {
$env{PERLBREW_PERL} = $perl_name;
- $env{PERLBREW_PATH} .= ":" . catdir($self->root, "perls", $perl_name, "bin");
- $env{PERLBREW_MANPATH} = catdir($self->root, "perls", $perl_name, "man")
+ $env{PERLBREW_PATH} .= ":" . joinpath($self->root, "perls", $perl_name, "bin");
+ $env{PERLBREW_MANPATH} = joinpath($self->root, "perls", $perl_name, "man")
}
if ($lib_name) {
require local::lib;
- no warnings 'uninitialized';
if ($ENV{PERL_LOCAL_LIB_ROOT}
&& $ENV{PERL_LOCAL_LIB_ROOT} =~ /^\Q$PERLBREW_HOME\E/
@@ -1246,12 +1560,12 @@ sub perlbrew_env {
if (-d $base) {
delete $ENV{PERL_LOCAL_LIB_ROOT};
@ENV{keys %env} = values %env;
+ while (my ($k,$v) = each %ENV) {
+ delete $ENV{$k} unless defined($v);
+ }
my %lib_env = local::lib->build_environment_vars_for($base, 0, 1);
-
- $lib_env{PERL5LIB} = (split($Config{path_sep}, $lib_env{PERL5LIB}, 2))[1];
-
- $env{PERLBREW_PATH} = catdir($base, "bin") . ":" . $env{PERLBREW_PATH};
- $env{PERLBREW_MANPATH} = catdir($base, "man") . ":" . $env{PERLBREW_MANPATH};
+ $env{PERLBREW_PATH} = joinpath($base, "bin") . ":" . $env{PERLBREW_PATH};
+ $env{PERLBREW_MANPATH} = joinpath($base, "man") . ":" . $env{PERLBREW_MANPATH};
$env{PERLBREW_LIB} = $lib_name;
$env{PERL_MM_OPT} = $lib_env{PERL_MM_OPT};
@@ -1270,9 +1584,9 @@ sub perlbrew_env {
}
if (my $perl5lib = $self->env("PERL5LIB")) {
my @perl5libs = split $Config{path_sep} => $perl5lib;
- my @prestine_perl5libs = grep { !/^\Q$PERLBREW_HOME\E/ } @perl5libs;
- if (@prestine_perl5libs) {
- $env{PERL5LIB} = join $Config{path_sep}, @prestine_perl5libs;
+ my @pristine_perl5libs = grep { !/^\Q$PERLBREW_HOME\E/ } @perl5libs;
+ if (@pristine_perl5libs) {
+ $env{PERL5LIB} = join $Config{path_sep}, @pristine_perl5libs;
}
else {
$env{PERL5LIB} = undef;
@@ -1354,16 +1668,19 @@ WARNINGONMAC
my $root = $self->root;
# The user does not source bashrc/csh in their shell initialization.
$env{PATH} = $env{PERLBREW_PATH} . ":" . join ":", grep { !/$root\/bin/ } split ":", $ENV{PATH};
- $env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":", grep { !/$root\/man/ } split ":", $ENV{MANPATH};
+ $env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":", grep { !/$root\/man/ }
+ ( defined($ENV{MANPATH}) ? split(":", $ENV{MANPATH}) : () );
}
my $command = "env ";
while (my ($k, $v) = each(%env)) {
+ no warnings "uninitialized";
$command .= "$k=\"$v\" ";
}
$command .= " $shell $shell_opt";
- print "\nA sub-shell is launched with $name as the activated perl. Run 'exit' to finish it.\n\n";
+ my $pretty_name = defined($name) ? $name : "the default perl";
+ print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n";
exec($command);
}
@@ -1404,7 +1721,7 @@ sub switch_to {
die "Cannot use for alias something that starts with 'perl-'\n"
if $alias && $alias =~ /^perl-/;
- die "${dist} is not installed\n" unless -d catdir($self->root, "perls", $dist);
+ die "${dist} is not installed\n" unless -d joinpath($self->root, "perls", $dist);
if ($self->env("PERLBREW_BASHRC_VERSION")) {
local $ENV{PERLBREW_PERL} = $dist;
@@ -1412,7 +1729,7 @@ sub switch_to {
my $pb_home = $self->env("PERLBREW_HOME") || $PERLBREW_HOME;
mkpath($pb_home);
- system("$0 env $dist > " . catfile($pb_home, "init"));
+ system("$0 env $dist > " . joinpath($pb_home, "init"));
print "Switched to $dist.\n\n";
}
@@ -1431,7 +1748,7 @@ sub run_command_switch_off {
my $pb_home = $self->env("PERLBREW_HOME") || $PERLBREW_HOME;
mkpath($pb_home);
- system("env PERLBREW_PERL= $0 env > " . catfile($pb_home, "init"));
+ system("env PERLBREW_PERL= $0 env > " . joinpath($pb_home, "init"));
print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n";
print "To immediately make it effective, run this line in this terminal:\n\n exec @{[ $self->env('SHELL') ]}\n\n";
@@ -1562,19 +1879,15 @@ sub run_command_install_patchperl {
sub run_command_install_cpanm {
my ($self) = @_;
- $self->do_install_program_from_url('https://github.com/miyagawa/cpanminus/raw/master/cpanm' => 'cpanm');
-}
-
-sub run_command_install_ack {
- my ($self) = @_;
- $self->do_install_program_from_url('http://betterthangrep.com/ack-standalone' => 'ack');
+ $self->do_install_program_from_url('https://raw.github.com/miyagawa/cpanminus/master/cpanm' => 'cpanm');
}
sub run_command_self_upgrade {
my ($self) = @_;
my $TMPDIR = $ENV{TMPDIR} || "/tmp";
- my $TMP_PERLBREW = catfile($TMPDIR, "perlbrew");
+ my $TMP_PERLBREW = joinpath($TMPDIR, "perlbrew");
+ require FindBin;
unless(-w $FindBin::Bin) {
die "Your perlbrew installation appears to be system-wide. Please upgrade through your package manager.\n";
}
@@ -1630,28 +1943,34 @@ sub run_command_exec {
local (@ARGV) = @{$self->{original_argv}};
Getopt::Long::Configure ('require_order');
- my @command_options = ('with=s');
+ my @command_options = ('with=s', 'halt-on-error');
$self->parse_cmdline (\%opts, @command_options);
shift @ARGV; # "exec"
$self->parse_cmdline (\%opts, @command_options);
- my @exec_with = map { ($_, @{$_->{libs}}) } $self->installed_perls;
-
+ my @exec_with;
if ($opts{with}) {
+ my %installed = map { $_->{name} => $_ } map { ($_, @{$_->{libs}}) } $self->installed_perls;
+
my $d = ($opts{with} =~ / /) ? qr( +) : qr(,+);
- my %x = map { $_ => 1 } grep { $_ } map {
+ my @with = grep { $_ } map {
my ($p,$l) = $self->resolve_installation_name($_);
$p .= "\@$l" if $l;
$p;
} split $d, $opts{with};
- @exec_with = grep { $x{ $_->{name} } } @exec_with;
+
+ @exec_with = map { $installed{$_} } @with;
+ }
+ else {
+ @exec_with = map { ($_, @{$_->{libs}}) } $self->installed_perls;
}
if (0 == @exec_with) {
print "No perl installation found.\n" unless $self->{quiet};
}
+ my $overall_success = 1;
for my $i ( @exec_with ) {
next if -l $self->root . '/perls/' . $i->{name}; # Skip Aliases
my %env = $self->perlbrew_env($i->{name});
@@ -1660,11 +1979,28 @@ sub run_command_exec {
local @ENV{ keys %env } = values %env;
local $ENV{PATH} = join(':', $env{PERLBREW_PATH}, $ENV{PATH});
local $ENV{MANPATH} = join(':', $env{PERLBREW_MANPATH}, $ENV{MANPATH}||"");
+ local $ENV{PERL5LIB} = $env{PERL5LIB} || "";
print "$i->{name}\n==========\n" unless $self->{quiet};
- $self->do_system(@ARGV);
+
+
+ if (my $err = $self->do_system_with_exit_code(@ARGV)) {
+ my $exit_code = $err >> 8;
+ # return 255 for case when process was terminated with signal, in that case real exit code is useless and weird
+ $exit_code = 255 if $exit_code > 255;
+ $overall_success = 0;
+ print "Command terminated with non-zero status.\n" unless $self->{quiet};
+
+ print STDERR "Command [" .
+ join(' ', map { /\s/ ? "'$_'" : $_ } @ARGV) . # trying reverse shell escapes - quote arguments containing spaces
+ "] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";
+ print STDERR $self->format_info_output;
+
+ $self->do_exit_with_error_code($exit_code) if ($opts{'halt-on-error'});
+ }
print "\n\n" unless $self->{quiet};
}
+ $self->do_exit_with_error_code(1) unless $overall_success;
}
sub run_command_clean {
@@ -1673,10 +2009,16 @@ sub run_command_clean {
my @build_dirs = <$root/build/*>;
for my $dir (@build_dirs) {
- print "Remove $dir\n";
+ print "Removing $dir\n";
rmpath($dir);
}
+ my @tarballs = <$root/dists/*>;
+ for my $file ( @tarballs ) {
+ print "Removing $file\n";
+ unlink($file);
+ }
+
print "\nDone\n";
}
@@ -1697,18 +2039,16 @@ USAGE
return;
}
- unless ( $self->is_installed($name) ) {
- die "\nABORT: The installation `${name}` does not exist.\n\n";
- }
-
- my $path_name = catfile($self->root, "perls", $name);
- my $path_alias = catfile($self->root, "perls", $alias) if $alias;
+ my $path_name = joinpath($self->root, "perls", $name);
+ my $path_alias = joinpath($self->root, "perls", $alias) if $alias;
if ($alias && -e $path_alias && !-l $path_alias) {
die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n";
}
if ($cmd eq 'create') {
+ $self->assert_known_installation($name);
+
if ( $self->is_installed($alias) && !$self->{force} ) {
die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n";
}
@@ -1718,6 +2058,8 @@ USAGE
symlink($path_name, $path_alias);
}
elsif($cmd eq 'delete') {
+ $self->assert_known_installation($name);
+
unless (-l $path_name) {
die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n";
}
@@ -1725,6 +2067,8 @@ USAGE
unlink($path_name);
}
elsif($cmd eq 'rename') {
+ $self->assert_known_installation($name);
+
unless (-l $path_name) {
die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n";
}
@@ -1735,6 +2079,9 @@ USAGE
rename($path_name, $path_alias);
}
+ elsif($cmd eq 'help') {
+ $self->run_command_help("alias");
+ }
else {
die "\nERROR: Unrecognized action: `${cmd}`.\n\n";
}
@@ -1801,7 +2148,7 @@ sub run_command_lib_create {
}
my $fullname = $perl_name . '@' . $lib_name;
- my $dir = catdir($PERLBREW_HOME, "libs", $fullname);
+ my $dir = joinpath($PERLBREW_HOME, "libs", $fullname);
if (-d $dir) {
die "$fullname is already there.\n";
@@ -1824,14 +2171,11 @@ sub run_command_lib_delete {
my ($perl_name, $lib_name) = $self->resolve_installation_name($name);
- if (!$perl_name) {
- }
-
my $fullname = $perl_name . '@' . $lib_name;
my $current = $self->current_perl . '@' . ($self->env("PERLBREW_LIB") || "");
- my $dir = catdir($PERLBREW_HOME, "libs", $fullname);
+ my $dir = joinpath($PERLBREW_HOME, "libs", $fullname);
if (-d $dir) {
@@ -1859,7 +2203,7 @@ sub run_command_lib_list {
$current = $self->current_perl . "@" . $self->env("PERLBREW_LIB");
}
- my $dir = catdir($PERLBREW_HOME, "libs");
+ my $dir = joinpath($PERLBREW_HOME, "libs");
return unless -d $dir;
opendir my $dh, $dir or die "open $dir failed: $!";
@@ -1918,19 +2262,19 @@ sub run_command_upgrade_perl {
print "Upgrading $current->{name} to $dist_version\n" unless $self->{quiet};
local $self->{as} = $current->{name};
local $self->{dist_name} = $dist;
- $self->do_install_release($dist, "perl", $dist_version);
+ $self->do_install_release($dist, $dist_version);
}
sub run_command_list_modules {
my ($self) = @_;
-
- $self->{quiet} = 1;
- $self->{original_argv} = [
- "exec", "--with", $self->current_perl,
- 'perl', '-MExtUtils::Installed', '-le', 'BEGIN{@INC=grep(!/^\.$/,@INC)}; print for ExtUtils::Installed->new->modules'
- ];
-
- $self->run_command_exec();
+ my $class = ref($self) || __PACKAGE__;
+ my $app = $class->new(
+ qw(--quiet exec --with),
+ $self->current_env,
+ 'perl', '-MExtUtils::Installed', '-le',
+ 'BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;'
+ );
+ $app->run;
}
sub resolve_installation_name {
@@ -1953,27 +2297,44 @@ sub resolve_installation_name {
return wantarray ? ($perl_name, $lib_name) : $perl_name;
}
-sub run_command_info {
- my ($self) = @_;
+sub format_info_output
+{
+ my ($self, $module) = @_;
- local $\ = "\n";
+ my $out = '';
- print "Current perl:";
+ $out .= "Current perl:\n";
if ($self->current_perl) {
- print " Name: " . $self->current_perl . ($self->current_lib && "@".$self->current_lib);
- print " Path: " . $self->current_perl_executable;
+ $out .= " Name: " . $self->current_env . "\n";
+ $out .= " Path: " . $self->installed_perl_executable($self->current_perl) . "\n";
+ $out .= " Config: " . $self->configure_args( $self->current_perl ) . "\n";
+ $out .= join('', " Compiled at: ", (map {
+ / Compiled at (.+)\n/ ? $1 : ()
+ } `@{[ $self->installed_perl_executable($self->current_perl) ]} -V`), "\n");
}
else {
- print "Using system perl.";
- print "Shebang: " . $self->system_perl_shebang;
+ $out .= "Using system perl." . "\n";
+ $out .= "Shebang: " . $self->system_perl_shebang . "\n";
}
- print "\nperlbrew:";
- print " version: " . $self->VERSION;
- print " ENV:";
+ $out .= "\nperlbrew:\n";
+ $out .= " version: " . $self->VERSION . "\n";
+ $out .= " ENV:\n";
for(map{"PERLBREW_$_"}qw(ROOT HOME PATH MANPATH)) {
- print " $_: " . ($self->env($_)||"");
+ $out .= " $_: " . ($self->env($_)||"") . "\n";
}
+
+ if ( $module ) {
+ my $code = qq{eval "require $module" and do { (my \$f = "$module") =~ s<::></>g; \$f .= ".pm"; print "$module\n Location: \$INC{\$f}\n Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } };
+ $out .= "\nModule: ".$self->do_capture( $self->installed_perl_executable($self->current_perl), "-le", $code );
+ }
+
+ $out;
+}
+
+sub run_command_info {
+ my ($self) = shift;
+ print $self->format_info_output(@_);
}
@@ -1985,7 +2346,7 @@ sub config {
sub config_file {
my ($self) = @_;
- catfile( $self->root, 'Config.pm' );
+ joinpath( $self->root, 'Config.pm' );
}
sub _save_config {
@@ -2020,7 +2381,7 @@ sub _load_config {
}
sub BASHRC_CONTENT() {
- return "export PERLBREW_BASHRC_VERSION=$VERSION\n\n" . <<'RC';
+ return "export PERLBREW_BASHRC_VERSION=$VERSION\n\n" . sprintf <<'RC', $PERLBREW_ROOT;
__perlbrew_reinit() {
if [[ ! -d "$PERLBREW_HOME" ]]; then
@@ -2028,7 +2389,7 @@ __perlbrew_reinit() {
fi
echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
- command perlbrew env $1 | grep PERLBREW_ >> "$PERLBREW_HOME/init"
+ command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
. "$PERLBREW_HOME/init"
__perlbrew_set_path
}
@@ -2042,7 +2403,7 @@ __perlbrew_set_path () {
fi
unset MANPATH_WITHOUT_PERLBREW
- PATH_WITHOUT_PERLBREW=`$perlbrew_command display-pristine-path`
+ PATH_WITHOUT_PERLBREW=$(eval $perlbrew_command display-pristine-path)
if [ -n "$PERLBREW_PATH" ]; then
export PATH=${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW}
else
@@ -2053,14 +2414,24 @@ __perlbrew_set_path () {
hash -r
}
+__perlbrew_set_env() {
+ local code="$($perlbrew_command env $@)"
+ local exit_status="$?"
+ if [[ $exit_status -eq 0 ]] ; then
+ eval "$code"
+ else
+ return $exit_status
+ fi
+}
+
__perlbrew_activate() {
[[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null
if [[ -n "$PERLBREW_PERL" ]]; then
if [[ -z "$PERLBREW_LIB" ]]; then
- eval "$($perlbrew_command env $PERLBREW_PERL)"
+ __perlbrew_set_env $PERLBREW_PERL
else
- eval "$(${perlbrew_command} env $PERLBREW_PERL@$PERLBREW_LIB)"
+ __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB
fi
fi
@@ -2068,7 +2439,7 @@ __perlbrew_activate() {
}
__perlbrew_deactivate() {
- eval "$($perlbrew_command env)"
+ __perlbrew_set_env
unset PERLBREW_PERL
unset PERLBREW_LIB
__perlbrew_set_path
@@ -2095,11 +2466,10 @@ perlbrew () {
echo "Currently using $PERLBREW_PERL"
fi
else
- code="$(command perlbrew env $2);"
- if [ -z "$code" ]; then
- exit_status=1
- else
- eval $code
+ __perlbrew_set_env "$2"
+ exit_status="$?"
+ if [[ $exit_status -eq 0 ]]
+ then
__perlbrew_set_path
fi
fi
@@ -2109,7 +2479,11 @@ perlbrew () {
if [[ -z "$2" ]] ; then
command perlbrew switch
else
- perlbrew use $2 && __perlbrew_reinit $2
+ perlbrew use $2
+ exit_status=$?
+ if [[ ${exit_status} -eq 0 ]]; then
+ __perlbrew_reinit $2
+ fi
fi
;;
@@ -2133,7 +2507,7 @@ perlbrew () {
return ${exit_status:-0}
}
-[[ -z "$PERLBREW_ROOT" ]] && export PERLBREW_ROOT="$HOME/perl5/perlbrew"
+[[ -z "$PERLBREW_ROOT" ]] && export PERLBREW_ROOT="%s"
[[ -z "$PERLBREW_HOME" ]] && export PERLBREW_HOME="$HOME/.perlbrew"
if [[ ! -n "$PERLBREW_SKIP_INIT" ]]; then
@@ -2146,7 +2520,7 @@ perlbrew_bin_path="${PERLBREW_ROOT}/bin"
if [[ -f $perlbrew_bin_path/perlbrew ]]; then
perlbrew_command="$perlbrew_bin_path/perlbrew"
else
- perlbrew_command="command perlbrew"
+ perlbrew_command="perlbrew"
fi
unset perlbrew_bin_path
@@ -2171,6 +2545,173 @@ complete -F _perlbrew_compgen perlbrew
COMPLETION
}
+sub PERLBREW_FISH_CONTENT {
+ return "set -x PERLBREW_FISH_VERSION $VERSION\n" . <<'END';
+
+function __perlbrew_reinit;
+ if not test -d "$PERLBREW_HOME"
+ mkdir-p "$PERLBREW_HOME"
+ end
+
+ echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init"
+ command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init"
+ __source_init
+ __perlbrew_set_path
+end
+
+function __perlbrew_set_path;
+ set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join " ", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);')
+
+ if test -n "$PERLBREW_MANPATH"
+ set -x MANPATH $PERLBREW_MANPATH $MANPATH_WITHOUT_PERLBREW
+ else
+ set -x MANPATH $MANPATH_WITHOUT_PERLBREW
+ end
+
+ set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /')
+
+ if test -n "$PERLBREW_PATH"
+ set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' )
+ eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW
+ else
+ eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW
+ end
+end
+
+function __perlbrew_set_env;
+ set -l code (eval $perlbrew_command env $argv | perl -pe 's/export\s+(\S+)="(\S*)"/set -x $1 $2;/g; y/:/ /')
+
+ if test -z "$code"
+ return 0;
+ else
+ eval $code
+ end
+
+end
+
+function __perlbrew_activate;
+ functions -e perl
+
+ if test -n "$PERLBREW_PERL"
+ if test -z "$PERLBREW_LIB"
+ __perlbrew_set_env $PERLBREW_PERL
+ else
+ __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB
+ end
+ end
+
+ __perlbrew_set_path
+end
+
+function __perlbrew_deactivate
+ __perlbrew_set_env
+ set -r PERLBREW_PERL
+ set -r PERLBREW_LIB
+ __perlbrew_set_path
+end
+
+function perlbrew;
+
+ switch $argv[1]
+ case use
+ if test ( count $argv ) -eq 1
+ if test -x "$PERLBREW_PERL"
+ echo "Currently using system perl"
+ else
+ echo "Currently using $PERLBREW_PERL"
+ end
+ else
+ __perlbrew_set_env $argv[2]
+ if test "$status" -eq 0
+ __perlbrew_set_path
+ end
+ end
+
+ case switch
+ if test ( count $argv ) -eq 1
+ command perlbrew switch
+ else
+ perlbrew use $argv[2]
+ if test "$status" -eq 0
+ __perlbrew_reinit $argv[2]
+ end
+ end
+
+ case off
+ __perlbrew_deactivate
+ echo "perlbrew is turned off."
+
+ case switch-off
+ __perlbrew_deactivate
+ __perlbrew_reinit
+ echo "perlbrew is switched off."
+
+ case '*'
+ command perlbrew $argv
+
+
+ end
+end
+
+function __source_init
+ eval (perl -pe's/^export/set -x/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init")
+end
+
+if test -z "$PERLBREW_ROOT"
+ set -x PERLBREW_ROOT "$HOME/perl5/perlbrew"
+end
+
+if test -x "$PERLBREW_HOME"
+ set -x PERLBREW_HOME "$HOME/.perlbrew"
+end
+
+if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init"
+ __source_init
+end
+
+set perlbrew_bin_path "$PERLBREW_ROOT/bin"
+
+if test -f "$perlbrew_bin_path/perlbrew"
+ set perlbrew_command "$perlbrew_bin_path/perlbrew"
+else
+ set perlbrew_command perlbrew
+end
+
+set -e perlbrew_bin_path
+
+__perlbrew_activate
+
+## autocomplete stuff #############################################
+
+function __fish_perlbrew_needs_command
+ set cmd (commandline -opc)
+ if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew'
+ return 0
+ end
+ return 1
+end
+
+function __fish_perlbrew_using_command
+ set cmd (commandline -opc)
+ if test (count $cmd) -gt 1
+ if [ $argv[1] = $cmd[2] ]
+ return 0
+ end
+ end
+end
+
+for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//')
+ complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com
+end
+
+for com in switch use;
+ complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \
+ -a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')'
+end
+
+END
+}
+
sub CSH_WRAPPER_CONTENT {
return <<'WRAPPER';
set perlbrew_exit_status=0
@@ -2393,7 +2934,7 @@ close to what your want to read.
=head1 INSTALLATION
-It is the simpleist to use the perlbrew installer, just paste this statement to
+It is the simplest to use the perlbrew installer, just paste this statement to
your terminal:
curl -kL http://install.perlbrew.pl | bash
@@ -2407,7 +2948,7 @@ should follow the instruction on screen to modify your shell rc file to put it
in your PATH.
The installed perlbrew command is a standalone executable that can be run with
-system perl. The minimun system perl version requirement is 5.8.0, which should
+system perl. The minimum system perl version requirement is 5.8.0, which should
be good enough for most of the OSes these days.
A packed version of C<patchperl> to C<~/perl5/perlbrew/bin>, which is required
@@ -7,6 +7,7 @@ use App::perlbrew;
require 'test_helpers.pl';
use Test::Spec;
+use Test::Output;
mock_perlbrew_install("perl-5.12.3");
mock_perlbrew_install("perl-5.12.4");
@@ -19,7 +20,7 @@ describe 'perlbrew exec perl -E "say 42"' => sub {
my @perls = $app->installed_perls;
- $app->expects("do_system")->exactly(4)->returns(
+ $app->expects("do_system_with_exit_code")->exactly(4)->returns(
sub {
my ($self, @args) = @_;
@@ -44,7 +45,7 @@ describe 'perlbrew exec --with perl-5.12.3 perl -E "say 42"' => sub {
it "invokes perl-5.12.3/bin/perl" => sub {
my $app = App::perlbrew->new(qw(exec --with perl-5.12.3 perl -E), "say 42");
- $app->expects("do_system")->returns(
+ $app->expects("do_system_with_exit_code")->returns(
sub {
my ($self, @args) = @_;
@@ -63,4 +64,197 @@ describe 'perlbrew exec --with perl-5.12.3 perl -E "say 42"' => sub {
};
};
+describe 'perlbrew exec --with perl-5.14.1,perl-5.12.3,perl-5.14.2 perl -E "say 42"' => sub {
+ it "invokes each perl in the specified order" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1 perl-5.12.3 perl-5.14.2", qw(perl -E), "say 42");
+
+ my @perl_paths;
+ $app->expects("do_system_with_exit_code")->exactly(3)->returns(
+ sub {
+ my ($self, @args) = @_;
+ my ($perlbrew_bin_path, $perlbrew_perl_bin_path, @paths) = split(":", $ENV{PATH});
+ push @perl_paths, $perlbrew_perl_bin_path;
+ return 0;
+ }
+ );
+
+ $app->run;
+
+ is_deeply \@perl_paths, [
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.14.1", "bin"),
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.12.3", "bin"),
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.14.2", "bin"),
+ ];
+ };
+};
+
+describe 'perlbrew exec --with perl-5.14.1,perl-foobarbaz, ' => sub {
+ it "ignore the unrecognized 'perl-foobarbaz'" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1 perl-foobarbaz", qw(perl -E), "say 42");
+
+ my @perl_paths;
+ $app->expects("do_system_with_exit_code")->returns(
+ sub {
+ my ($self, @args) = @_;
+ my ($perlbrew_bin_path, $perlbrew_perl_bin_path, @paths) = split(":", $ENV{PATH});
+ push @perl_paths, $perlbrew_perl_bin_path;
+ return 0;
+ }
+ );
+
+ $app->run;
+
+ is_deeply \@perl_paths, [
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.14.1", "bin"),
+ ];
+ };
+};
+
+describe 'perlbrew exec --with perl-5.14.1,5.14.1 ' => sub {
+ it "exec 5.14.1 twice, since that is what is specified" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1 5.14.1", qw(perl -E), "say 42");
+
+ my @perl_paths;
+ $app->expects("do_system_with_exit_code")->exactly(2)->returns(
+ sub {
+ my ($self, @args) = @_;
+ my ($perlbrew_bin_path, $perlbrew_perl_bin_path, @paths) = split(":", $ENV{PATH});
+ push @perl_paths, $perlbrew_perl_bin_path;
+ return 0;
+ }
+ );
+
+ $app->run;
+
+ is_deeply \@perl_paths, [
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.14.1", "bin"),
+ file($App::perlbrew::PERLBREW_ROOT, "perls", "perl-5.14.1", "bin"),
+ ];
+ };
+};
+
+describe 'exec exit code' => sub {
+ describe "logging" => sub {
+ it "should work" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1", qw(perl -E), "somesub 42");
+ $app->expects("format_info_output")->exactly(1)->returns("format_info_output_value\n");
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(7<<8);
+ stderr_is sub {
+ eval { $app->run; 1; };
+ }, <<"OUT";
+Command [perl -E 'somesub 42'] terminated with exit code 7 (\$? = 1792) under the following perl environment:
+format_info_output_value
+OUT
+ };
+ it "should format info output for right perl" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1", qw(perl -E), "somesub 42");
+ $app->expects("format_info_output")->exactly(1)->returns(sub {
+ my ($self) = @_;
+ is $self->current_env, 'perl-5.14.1';
+ like $self->installed_perl_executable('perl-5.14.1'), qr/perl-5.14.1/;
+ "format_info_output_value\n";
+ });
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(7<<8);
+ eval { $app->run; 1; };
+ };
+ };
+ describe "no halt-on-error" => sub {
+ it "should exit with success code when several perls ran" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1 perl-5.14.1", qw(perl -E), "say 42");
+ App::perlbrew->expects("do_exit_with_error_code")->never;
+ $app->expects("do_system_with_exit_code")->exactly(2)->returns(0);
+ $app->run;
+ };
+ it "should exit with error code " => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1", qw(perl -E), "say 42");
+ $app->expects("format_info_output")->exactly(1)->returns('');
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ my ($self, $code) = @_;
+ is $code, 1; # exit with error, but don't propogate exact failure codes
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(3<<8);
+ ok !eval { $app->run; 1; };
+ is $@, "simulate exit\n";
+ };
+ it "should exit with error code when several perls ran" => sub {
+ my $app = App::perlbrew->new(qw(exec --with), "perl-5.14.1 perl-5.14.1", qw(perl -E), "say 42");
+ $app->expects("format_info_output")->exactly(1)->returns('');
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ my ($self, $code) = @_;
+ is $code, 1; # exit with error, but don't propogate exact failure codes
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(sub {
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(sub { # make sure second call to exec is made
+ 0; # second call is success
+ });
+ 3<<8; # first exec failed
+ });
+ ok !eval { $app->run; 1; };
+ is $@, "simulate exit\n";
+ };
+ };
+ describe "halt-on-error" => sub {
+ it "should exit with success code " => sub {
+ my $app = App::perlbrew->new(qw(exec --halt-on-error --with), "perl-5.14.1", qw(perl -E), "say 42");
+ App::perlbrew->expects("do_exit_with_error_code")->never;
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(0);
+ $app->run;
+ };
+ it "should exit with error code " => sub {
+ my $app = App::perlbrew->new(qw(exec --halt-on-error --with), "perl-5.14.1", qw(perl -E), "say 42");
+ $app->expects("format_info_output")->exactly(1)->returns('');
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ my ($self, $code) = @_;
+ is $code, 3;
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(3<<8);
+ ok !eval { $app->run; 1; };
+ is $@, "simulate exit\n";
+
+ };
+ it "should exit with code 255 if program terminated with signal or something" => sub {
+ my $app = App::perlbrew->new(qw(exec --halt-on-error --with), "perl-5.14.1", qw(perl -E), "say 42");
+ $app->expects("format_info_output")->exactly(1)->returns('');
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ my ($self, $code) = @_;
+ is $code, 255;
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(-1);
+ ok !eval { $app->run; 1; };
+ is $@, "simulate exit\n";
+
+ };
+ it "should exit with error code when several perls ran" => sub {
+ my $app = App::perlbrew->new(qw(exec --halt-on-error --with), "perl-5.14.1 perl-5.14.1", qw(perl -E), "say 42");
+ $app->expects("format_info_output")->exactly(1)->returns('');
+ App::perlbrew->expects("do_exit_with_error_code")->exactly(1)->returns(sub {
+ my ($self, $code) = @_;
+ is $code, 7;
+ die "simulate exit\n";
+ });
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(sub {
+ $app->expects("do_system_with_exit_code")->exactly(1)->returns(sub {
+ 7<<8;
+ });
+ 0;
+ });
+ ok !eval { $app->run; 1; };
+ is $@, "simulate exit\n";
+ };
+ };
+};
+
+
+
+
runtests unless caller;