<commit_before>package App::perlbrew;
use strict;
use warnings;
use 5.008;
our $VERSION = "0.64";

BEGIN {
    ### Special treat for Cwd to prevent it to be loaded from a local::lib dir that is not binary-compatible with system perl.
    if (my $perl5lib = $ENV{PERL5LIB}) {
        delete $ENV{PERL5LIB};
        require Cwd;
        $ENV{PERL5LIB} = $perl5lib;
    }
}

use Config;
use Getopt::Long ();

### global variables

local $SIG{__DIE__} = sub {
    my $message = shift;
    warn $message;
    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' }
              );


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 {
    require File::Path;
    File::Path::rmtree([@_], 0, 0);
}

sub min(@) {
    my @a = @_;
    my $m = $a[0];
    for my $x (@a) {
        $m = $x if $x < $m
    }
    return $m;
}

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;

    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 1
}

{
    my @command;
    sub http_get {
        my ($url, $header, $cb) = @_;

        if (ref($header) eq 'CODE') {
            $cb = $header;
            $header = undef;
        }

        if (! @command) {
            my @commands = (
                # curl's --fail option makes the exit code meaningful
                [qw( curl --silent --location --fail )],
                [qw( wget --quiet -O - )],
                [qw( fetch -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;
        }

        open my $fh, '-|', @command, $url
            or die "open() for '@command $url': $!";

        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
            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
            and $?;
        die 'Server issued an error response.'
            if $command[0] eq 'wget' # Exit code is 8 on 404s etc
            and $? >> 8 == 8;

        return $cb ? $cb->($body) : $body;
    }
}

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;
    }
    else {
        $v[3] ||= $v[1] >= 6 ? 9 : 0;
        $v[3] =~ s/[^0-9]//g;
    }

    return $v[1]*1000000 + $v[2]*1000 + $v[3];
}

# 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];
}

### methods

sub new {
    my($class, @argv) = @_;

    my %opt = (
        original_argv  => \@argv,
        force => 0,
        quiet => 0,
        D => [],
        U => [],
        A => [],
        sitecustomize => '',
        noman => '',
        variation => '',
        both => [],
    );

    $opt{$_} = '' for keys %flavor;

    # 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);

    $opt{args} = \@ARGV;

    # 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;

    Getopt::Long::GetOptions(
        $params,

        'force|f!',
        'notest|n!',
        'quiet|q!',
        'verbose|v',
        'as=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
    )
      or run_command_help(1);
}

sub root {
    my ($self, $new_root) = @_;

    if (defined($new_root)) {
        $self->{root} = $new_root;
    }

    return $self->{root} || $PERLBREW_ROOT;
}

sub current_perl {
    my ($self, $v) = @_;
    $self->{current_perl} = $v if $v;
    return $self->{current_perl} || $self->env('PERLBREW_PERL')  || '';
}

sub current_lib {
    my ($self, $v) = @_;
    $self->{current_lib} = $v if $v;
    return $self->{current_lib} || $self->env('PERLBREW_LIB')  || '';
}

sub current_perl_executable {
    my ($self) = @_;
    return $self->installed_perl_executable($self->current_perl);
}

sub current_env {
    my ($self) = @_;
    my $l = $self->current_lib;
    $l = "@" . $l if $l;
    return $self->current_perl . $l;
}

sub installed_perl_executable {
    my ($self, $name) = @_;
    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://www.cpan.org";
        $self->{cpan_mirror} =~ s{/+$}{};
    }
    return $self->{cpan_mirror};
}

sub env {
    my ($self, $name) = @_;
    return $ENV{$name} if $name;
    return \%ENV;
}

sub path_with_tilde {
    my ($self, $dir) = @_;
    my $home = $self->env('HOME');
    $dir =~ s/^\Q$home\E/~/ if $home;
    return $dir;
}

sub is_shell_csh {
    my ($self) = @_;
    return 1 if $self->env('SHELL') =~ /(t?csh)/;
    return 0;
}

sub run {
    my($self) = @_;
    $self->run_command($self->args);
}

sub args {
    my ( $self ) = @_;
    return @{ $self->{args} };
}

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

    my $package =  ref $self ? ref $self : $self;

    my @commands;
    my $symtable = do {
        no strict 'refs';
        \%{$package . '::'};
    };

    foreach my $sym (keys %$symtable) {
        if($sym =~ /^run_command_/) {
            my $glob = $symtable->{$sym};
            if(defined *$glob{CODE}) {
                $sym =~ s/^run_command_//;
                $sym =~ s/_/-/g;
                push @commands, $sym;
            }
        }
    }

    return @commands;
}

sub find_similar_commands {
    my ( $self, $command ) = @_;
    my $SIMILAR_DISTANCE = 6;

    my @commands = sort {
        $a->[1] <=> $b->[1]
    } grep {
        defined
    } map {
        my $d = editdist($_, $command);

        ($d < $SIMILAR_DISTANCE) ? [ $_, $d ] : undef
    } $self->commands;

    if(@commands) {
        my $best  = $commands[0][1];
        @commands = map { $_->[0] } grep { $_->[1] == $best } @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;

    if($self->{version}) {
        $x = 'version';
    }
    elsif(!$x) {
        $x = 'help';
        @args = (0, $self->{help} ? 2 : 0);
    }
    elsif($x eq 'help') {
        @args = (0, 2) unless @args;
    }

    my $s = $self->can("run_command_$x");
    unless ($s) {
        $x =~ y/-/_/;
        $s = $self->can("run_command_$x");
    }

    unless($s) {
        my @commands = $self->find_similar_commands($x);

        if(@commands > 1) {
            @commands = map { '    ' . $_ } @commands;
            die "Unknown command: `$command`. Did you mean one of the following?\n" . join("\n", @commands) . "\n";
        } elsif(@commands == 1) {
            die "Unknown command: `$command`. Did you mean `$commands[0]`?\n";
        } else {
            die "Unknown command: `$command`. Typo?\n";
        }
    }

    $self->$s(@args);
}

sub run_command_version {
    my ( $self ) = @_;
    my $package = ref $self;
    my $version = $self->VERSION;
    print "$0  - $package/$version\n";
}

sub run_command_help {
    my ($self, $status, $verbose) = @_;

    require Pod::Usage;

    if ($status && !defined($verbose)) {
        if ($self->can("run_command_help_${status}")) {
            $self->can("run_command_help_${status}")->($self);
        }
        else {
            my $out = "";
            open my $fh, ">", \$out;

            Pod::Usage::pod2usage(
                -exitval   => "NOEXIT",
                -verbose   => 99,
                -sections  => "COMMAND: " . uc($status),
                -output    => $fh,
                -noperldoc => 1
            );
            $out =~ s/\A[^\n]+\n//s;
            $out =~ s/^    //gm;

            if ($out =~ /\A\s*\Z/) {
                $out = "Cannot find documentation for '$status'\n\n";
            }

            print "\n$out";
            close $fh;
        }
    }
    else {
        Pod::Usage::pod2usage(
            -noperldoc => 1,
            -verbose => $verbose||0,
            -exitval => (defined $status ? $status : 1)
        );
    }
}

# introspection for compgen
my %comp_installed = (
    use    => 1,
    switch => 1,
);

sub run_command_compgen {
    my($self, $cur, @args) = @_;

    $cur = 0 unless defined($cur);

    # do `tail -f bashcomp.log` for debugging
    if($self->env('PERLBREW_DEBUG_COMPLETION')) {
        open my $log, '>>', 'bashcomp.log';
        print $log "[$$] $cur of [@args]\n";
    }
    my $subcommand           = $args[1];
    my $subcommand_completed = ( $cur >= 2 );

    if(!$subcommand_completed) {
        $self->_compgen($subcommand, $self->commands);
    }
    else { # complete args of a subcommand
        if($comp_installed{$subcommand}) {
            if($cur <= 2) {
                my $part;
                if(defined($part = $args[2])) {
                    $part = qr/ \Q$part\E /xms;
                }
                $self->_compgen($part,
                    map{ $_->{name} } $self->installed_perls());
            }
        }
        elsif($subcommand eq 'help') {
            if($cur <= 2) {
                $self->_compgen($args[2], $self->commands());
            }
        }
        else {
            # TODO
        }
    }
}

sub _compgen {
    my($self, $part, @reply) = @_;
    if(defined $part) {
        $part = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//);
        @reply = grep { /$part/ } @reply;
    }
    foreach my $word(@reply) {
        print $word, "\n";
    }
}

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

    my @available = $self->available_perls(@_);
    my @installed = $self->installed_perls(@_);

    my $is_installed;
    for my $available (@available) {
        $is_installed = 0;
        for my $installed (@installed) {
            my $name = $installed->{name};
            my $cur  = $installed->{is_current};
            if ( $available eq $installed->{name} ) {
                $is_installed = 1;
                last;
            }
        }
        print $is_installed ? 'i ' : '  ', $available, "\n";
    }
}

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

    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) {
        die "\nERROR: Unable to retrieve the list of perls.\n\n";
    }

    my @available_versions;

    for ( split "\n", $html ) {
        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;

    return @available_versions;
}

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];

    if ($x) {
        my $dist_tarball = (split("/", $x))[-1];
        my $dist_tarball_url = $self->cpan_mirror() . "/authors/id/$x";
        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 locate perl-${version} tarball.";
    }

    my ($dist_path, $dist_tarball) =
        $html =~ m[<a href="(/CPAN/authors/id/.+/(perl-${version}.tar.(gz|bz2)))">Download</a>];
    die "ERROR: Cannot find the tarball for perl-$version\n"
        if !$dist_path and !$dist_tarball;
    my $dist_tarball_url = "http://search.cpan.org${dist_path}";
    return ($dist_tarball, $dist_tarball_url);
}

sub run_command_init {
    my $self = shift;
    my @args = @_;

    if (@args && $args[0] eq '-') {
        if ($self->is_shell_csh) {
        }
        else {
            $self->run_command_init_in_bash;
        }
        exit 0;
    }

    mkpath($_) for (grep { ! -d $_ } map { joinpath($self->root, $_) } qw(perls dists build etc bin));

    my ($f, $fh) = @_;

    my $etc_dir = joinpath($self->root, "etc");

    for (["bashrc", "BASHRC_CONTENT"],
         ["cshrc", "CSHRC_CONTENT"],
         ["csh_reinit",  "CSH_REINIT_CONTENT"],
         ["csh_wrapper", "CSH_WRAPPER_CONTENT"],
         ["csh_set_path", "CSH_SET_PATH_CONTENT"],
         ["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"],
     ) {
        my ($file_name, $method) = @$_;
        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;
            close $fh;
        }
        else {
            if (-w $path && open($fh, ">", $path)) {
                print $fh $self->$method;
                close $fh;
            }
            else {
                print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet};
            }
        }
    }

    my ( $shrc, $yourshrc );
    if ( $self->is_shell_csh) {
        $shrc     = 'cshrc';
        $self->env("SHELL") =~ m/(t?csh)/;
        $yourshrc = $1 . "rc";
    }
    elsif ($self->env("SHELL") =~ m/zsh\d?$/) {
        $shrc = "bashrc";
        $yourshrc = 'zshenv';
    }
    else {
        $shrc = "bashrc";
        $yourshrc = "bash_profile";
    }

    my $root_dir = $self->path_with_tilde($self->root);
    my $pb_home_dir = $self->path_with_tilde($PERLBREW_HOME);

    my $code = qq(    source $root_dir/etc/${shrc});
    if ($PERLBREW_HOME ne joinpath($ENV{HOME}, ".perlbrew")) {
        $code = "    export PERLBREW_HOME=$pb_home_dir\n" . $code;
    }

    print <<INSTRUCTION;

perlbrew root ($root_dir) is initialized.

Append the following piece of code to the end of your ~/.${yourshrc} and start a
new shell, perlbrew should be up and fully functional from there:

$code

Simply run `perlbrew` for usage details.

Happy brewing!

INSTRUCTION

}

sub run_command_init_in_bash {
    print BASHRC_CONTENT();
}

sub run_command_self_install {
    my $self = shift;

    my $executable = $0;
    my $target = joinpath($self->root, "bin", "perlbrew");

    if (files_are_the_same($executable, $target)) {
        print "You are already running the installed perlbrew:\n\n    $executable\n";
        exit;
    }

    mkpath( joinpath($self->root, "bin" ));

    open my $fh, "<", $executable;
    my @lines =  <$fh>;
    close $fh;

    $lines[0] = $self->system_perl_shebang . "\n";

    open $fh, ">", $target;
    print $fh $_ for @lines;
    close $fh;

    chmod(0755, $target);

    my $path = $self->path_with_tilde($target);

    print "perlbrew is installed: $path\n" unless $self->{quiet};

    $self->run_command_init();
    return;
}

sub do_install_git {
    my $self = shift;
    my $dist = shift;

    my $dist_name;
    my $dist_git_describe;
    my $dist_version;

    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_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;
}

sub do_install_url {
    my $self = shift;
    my $dist = shift;

    my $dist_name = 'perl';
    # need the period to account for the file extension
    my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;
    my ($dist_tarball) = $dist =~ m{/([^/]*)$};

    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

    if ($dist_tarball_url =~ m/^file/) {
        print "Installing $dist from local archive $dist_tarball_url\n";
        $dist_tarball_url =~ s/^file:\/+/\//;
        $dist_tarball_path = $dist_tarball_url;
    }
    else {
        print "Fetching $dist as $dist_tarball_path\n";
        $self->download($dist_tarball_url, $dist_tarball_path);
    }

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

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);
    return $extracted_dir;
}

sub do_install_blead {
    my $self = shift;
    my $dist = shift;

    my $dist_name           = 'perl';
    my $dist_git_describe   = 'blead';
    my $dist_version        = '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 = 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";
        }
    );


    # Returns the wrong extracted dir for blead
    $self->do_extract_tarball($dist_tarball_path);

    my $build_dir = joinpath($self->root, "build");
    local *DIRH;
    opendir DIRH, $build_dir or die "Couldn't open ${build_dir}: $!";
    my @contents = readdir DIRH;
    closedir DIRH or warn "Couldn't close ${build_dir}: $!";
    my @candidates = grep { m/^perl-[0-9a-f]{7,8}$/ } @contents;
    # Use a Schwartzian Transform in case there are lots of dirs that
    # look like "perl-$SHA1", which is what's inside blead.tar.gz,
    # so we stat each one only once.
    @candidates =   map  { $_->[0] }
                    sort { $b->[1] <=> $a->[1] } # descending
                    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_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 ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version);
    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 perl $dist_version as $dist_tarball_path\n" unless $self->{quiet};
        $self->download( $dist_tarball_url, $dist_tarball_path );
    }

    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($dist) {
        $self->run_command_help("install");
        exit(-1);
    }

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

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

        if ($version eq 'blead') {
            $self->do_install_blead($dist);
        }
        else {
            $self->do_install_release( $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 "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;
    }

    # 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

    if ($Config::Config{archname64} eq '') {
        # this is 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;<commit_msg>improve heuristic for detecting when we are running on a 64bit platform<commit_after>package App::perlbrew;
use strict;
use warnings;
use 5.008;
our $VERSION = "0.64";

BEGIN {
    ### Special treat for Cwd to prevent it to be loaded from a local::lib dir that is not binary-compatible with system perl.
    if (my $perl5lib = $ENV{PERL5LIB}) {
        delete $ENV{PERL5LIB};
        require Cwd;
        $ENV{PERL5LIB} = $perl5lib;
    }
}

use Config;
use Getopt::Long ();

### global variables

local $SIG{__DIE__} = sub {
    my $message = shift;
    warn $message;
    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' }
              );


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 {
    require File::Path;
    File::Path::rmtree([@_], 0, 0);
}

sub min(@) {
    my @a = @_;
    my $m = $a[0];
    for my $x (@a) {
        $m = $x if $x < $m
    }
    return $m;
}

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;

    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 1
}

{
    my @command;
    sub http_get {
        my ($url, $header, $cb) = @_;

        if (ref($header) eq 'CODE') {
            $cb = $header;
            $header = undef;
        }

        if (! @command) {
            my @commands = (
                # curl's --fail option makes the exit code meaningful
                [qw( curl --silent --location --fail )],
                [qw( wget --quiet -O - )],
                [qw( fetch -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;
        }

        open my $fh, '-|', @command, $url
            or die "open() for '@command $url': $!";

        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
            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
            and $?;
        die 'Server issued an error response.'
            if $command[0] eq 'wget' # Exit code is 8 on 404s etc
            and $? >> 8 == 8;

        return $cb ? $cb->($body) : $body;
    }
}

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;
    }
    else {
        $v[3] ||= $v[1] >= 6 ? 9 : 0;
        $v[3] =~ s/[^0-9]//g;
    }

    return $v[1]*1000000 + $v[2]*1000 + $v[3];
}

# 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];
}

### methods

sub new {
    my($class, @argv) = @_;

    my %opt = (
        original_argv  => \@argv,
        force => 0,
        quiet => 0,
        D => [],
        U => [],
        A => [],
        sitecustomize => '',
        noman => '',
        variation => '',
        both => [],
    );

    $opt{$_} = '' for keys %flavor;

    # 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);

    $opt{args} = \@ARGV;

    # 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;

    Getopt::Long::GetOptions(
        $params,

        'force|f!',
        'notest|n!',
        'quiet|q!',
        'verbose|v',
        'as=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
    )
      or run_command_help(1);
}

sub root {
    my ($self, $new_root) = @_;

    if (defined($new_root)) {
        $self->{root} = $new_root;
    }

    return $self->{root} || $PERLBREW_ROOT;
}

sub current_perl {
    my ($self, $v) = @_;
    $self->{current_perl} = $v if $v;
    return $self->{current_perl} || $self->env('PERLBREW_PERL')  || '';
}

sub current_lib {
    my ($self, $v) = @_;
    $self->{current_lib} = $v if $v;
    return $self->{current_lib} || $self->env('PERLBREW_LIB')  || '';
}

sub current_perl_executable {
    my ($self) = @_;
    return $self->installed_perl_executable($self->current_perl);
}

sub current_env {
    my ($self) = @_;
    my $l = $self->current_lib;
    $l = "@" . $l if $l;
    return $self->current_perl . $l;
}

sub installed_perl_executable {
    my ($self, $name) = @_;
    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://www.cpan.org";
        $self->{cpan_mirror} =~ s{/+$}{};
    }
    return $self->{cpan_mirror};
}

sub env {
    my ($self, $name) = @_;
    return $ENV{$name} if $name;
    return \%ENV;
}

sub path_with_tilde {
    my ($self, $dir) = @_;
    my $home = $self->env('HOME');
    $dir =~ s/^\Q$home\E/~/ if $home;
    return $dir;
}

sub is_shell_csh {
    my ($self) = @_;
    return 1 if $self->env('SHELL') =~ /(t?csh)/;
    return 0;
}

sub run {
    my($self) = @_;
    $self->run_command($self->args);
}

sub args {
    my ( $self ) = @_;
    return @{ $self->{args} };
}

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

    my $package =  ref $self ? ref $self : $self;

    my @commands;
    my $symtable = do {
        no strict 'refs';
        \%{$package . '::'};
    };

    foreach my $sym (keys %$symtable) {
        if($sym =~ /^run_command_/) {
            my $glob = $symtable->{$sym};
            if(defined *$glob{CODE}) {
                $sym =~ s/^run_command_//;
                $sym =~ s/_/-/g;
                push @commands, $sym;
            }
        }
    }

    return @commands;
}

sub find_similar_commands {
    my ( $self, $command ) = @_;
    my $SIMILAR_DISTANCE = 6;

    my @commands = sort {
        $a->[1] <=> $b->[1]
    } grep {
        defined
    } map {
        my $d = editdist($_, $command);

        ($d < $SIMILAR_DISTANCE) ? [ $_, $d ] : undef
    } $self->commands;

    if(@commands) {
        my $best  = $commands[0][1];
        @commands = map { $_->[0] } grep { $_->[1] == $best } @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;

    if($self->{version}) {
        $x = 'version';
    }
    elsif(!$x) {
        $x = 'help';
        @args = (0, $self->{help} ? 2 : 0);
    }
    elsif($x eq 'help') {
        @args = (0, 2) unless @args;
    }

    my $s = $self->can("run_command_$x");
    unless ($s) {
        $x =~ y/-/_/;
        $s = $self->can("run_command_$x");
    }

    unless($s) {
        my @commands = $self->find_similar_commands($x);

        if(@commands > 1) {
            @commands = map { '    ' . $_ } @commands;
            die "Unknown command: `$command`. Did you mean one of the following?\n" . join("\n", @commands) . "\n";
        } elsif(@commands == 1) {
            die "Unknown command: `$command`. Did you mean `$commands[0]`?\n";
        } else {
            die "Unknown command: `$command`. Typo?\n";
        }
    }

    $self->$s(@args);
}

sub run_command_version {
    my ( $self ) = @_;
    my $package = ref $self;
    my $version = $self->VERSION;
    print "$0  - $package/$version\n";
}

sub run_command_help {
    my ($self, $status, $verbose) = @_;

    require Pod::Usage;

    if ($status && !defined($verbose)) {
        if ($self->can("run_command_help_${status}")) {
            $self->can("run_command_help_${status}")->($self);
        }
        else {
            my $out = "";
            open my $fh, ">", \$out;

            Pod::Usage::pod2usage(
                -exitval   => "NOEXIT",
                -verbose   => 99,
                -sections  => "COMMAND: " . uc($status),
                -output    => $fh,
                -noperldoc => 1
            );
            $out =~ s/\A[^\n]+\n//s;
            $out =~ s/^    //gm;

            if ($out =~ /\A\s*\Z/) {
                $out = "Cannot find documentation for '$status'\n\n";
            }

            print "\n$out";
            close $fh;
        }
    }
    else {
        Pod::Usage::pod2usage(
            -noperldoc => 1,
            -verbose => $verbose||0,
            -exitval => (defined $status ? $status : 1)
        );
    }
}

# introspection for compgen
my %comp_installed = (
    use    => 1,
    switch => 1,
);

sub run_command_compgen {
    my($self, $cur, @args) = @_;

    $cur = 0 unless defined($cur);

    # do `tail -f bashcomp.log` for debugging
    if($self->env('PERLBREW_DEBUG_COMPLETION')) {
        open my $log, '>>', 'bashcomp.log';
        print $log "[$$] $cur of [@args]\n";
    }
    my $subcommand           = $args[1];
    my $subcommand_completed = ( $cur >= 2 );

    if(!$subcommand_completed) {
        $self->_compgen($subcommand, $self->commands);
    }
    else { # complete args of a subcommand
        if($comp_installed{$subcommand}) {
            if($cur <= 2) {
                my $part;
                if(defined($part = $args[2])) {
                    $part = qr/ \Q$part\E /xms;
                }
                $self->_compgen($part,
                    map{ $_->{name} } $self->installed_perls());
            }
        }
        elsif($subcommand eq 'help') {
            if($cur <= 2) {
                $self->_compgen($args[2], $self->commands());
            }
        }
        else {
            # TODO
        }
    }
}

sub _compgen {
    my($self, $part, @reply) = @_;
    if(defined $part) {
        $part = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//);
        @reply = grep { /$part/ } @reply;
    }
    foreach my $word(@reply) {
        print $word, "\n";
    }
}

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

    my @available = $self->available_perls(@_);
    my @installed = $self->installed_perls(@_);

    my $is_installed;
    for my $available (@available) {
        $is_installed = 0;
        for my $installed (@installed) {
            my $name = $installed->{name};
            my $cur  = $installed->{is_current};
            if ( $available eq $installed->{name} ) {
                $is_installed = 1;
                last;
            }
        }
        print $is_installed ? 'i ' : '  ', $available, "\n";
    }
}

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

    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) {
        die "\nERROR: Unable to retrieve the list of perls.\n\n";
    }

    my @available_versions;

    for ( split "\n", $html ) {
        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;

    return @available_versions;
}

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];

    if ($x) {
        my $dist_tarball = (split("/", $x))[-1];
        my $dist_tarball_url = $self->cpan_mirror() . "/authors/id/$x";
        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 locate perl-${version} tarball.";
    }

    my ($dist_path, $dist_tarball) =
        $html =~ m[<a href="(/CPAN/authors/id/.+/(perl-${version}.tar.(gz|bz2)))">Download</a>];
    die "ERROR: Cannot find the tarball for perl-$version\n"
        if !$dist_path and !$dist_tarball;
    my $dist_tarball_url = "http://search.cpan.org${dist_path}";
    return ($dist_tarball, $dist_tarball_url);
}

sub run_command_init {
    my $self = shift;
    my @args = @_;

    if (@args && $args[0] eq '-') {
        if ($self->is_shell_csh) {
        }
        else {
            $self->run_command_init_in_bash;
        }
        exit 0;
    }

    mkpath($_) for (grep { ! -d $_ } map { joinpath($self->root, $_) } qw(perls dists build etc bin));

    my ($f, $fh) = @_;

    my $etc_dir = joinpath($self->root, "etc");

    for (["bashrc", "BASHRC_CONTENT"],
         ["cshrc", "CSHRC_CONTENT"],
         ["csh_reinit",  "CSH_REINIT_CONTENT"],
         ["csh_wrapper", "CSH_WRAPPER_CONTENT"],
         ["csh_set_path", "CSH_SET_PATH_CONTENT"],
         ["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"],
     ) {
        my ($file_name, $method) = @$_;
        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;
            close $fh;
        }
        else {
            if (-w $path && open($fh, ">", $path)) {
                print $fh $self->$method;
                close $fh;
            }
            else {
                print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet};
            }
        }
    }

    my ( $shrc, $yourshrc );
    if ( $self->is_shell_csh) {
        $shrc     = 'cshrc';
        $self->env("SHELL") =~ m/(t?csh)/;
        $yourshrc = $1 . "rc";
    }
    elsif ($self->env("SHELL") =~ m/zsh\d?$/) {
        $shrc = "bashrc";
        $yourshrc = 'zshenv';
    }
    else {
        $shrc = "bashrc";
        $yourshrc = "bash_profile";
    }

    my $root_dir = $self->path_with_tilde($self->root);
    my $pb_home_dir = $self->path_with_tilde($PERLBREW_HOME);

    my $code = qq(    source $root_dir/etc/${shrc});
    if ($PERLBREW_HOME ne joinpath($ENV{HOME}, ".perlbrew")) {
        $code = "    export PERLBREW_HOME=$pb_home_dir\n" . $code;
    }

    print <<INSTRUCTION;

perlbrew root ($root_dir) is initialized.

Append the following piece of code to the end of your ~/.${yourshrc} and start a
new shell, perlbrew should be up and fully functional from there:

$code

Simply run `perlbrew` for usage details.

Happy brewing!

INSTRUCTION

}

sub run_command_init_in_bash {
    print BASHRC_CONTENT();
}

sub run_command_self_install {
    my $self = shift;

    my $executable = $0;
    my $target = joinpath($self->root, "bin", "perlbrew");

    if (files_are_the_same($executable, $target)) {
        print "You are already running the installed perlbrew:\n\n    $executable\n";
        exit;
    }

    mkpath( joinpath($self->root, "bin" ));

    open my $fh, "<", $executable;
    my @lines =  <$fh>;
    close $fh;

    $lines[0] = $self->system_perl_shebang . "\n";

    open $fh, ">", $target;
    print $fh $_ for @lines;
    close $fh;

    chmod(0755, $target);

    my $path = $self->path_with_tilde($target);

    print "perlbrew is installed: $path\n" unless $self->{quiet};

    $self->run_command_init();
    return;
}

sub do_install_git {
    my $self = shift;
    my $dist = shift;

    my $dist_name;
    my $dist_git_describe;
    my $dist_version;

    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_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;
}

sub do_install_url {
    my $self = shift;
    my $dist = shift;

    my $dist_name = 'perl';
    # need the period to account for the file extension
    my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;
    my ($dist_tarball) = $dist =~ m{/([^/]*)$};

    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

    if ($dist_tarball_url =~ m/^file/) {
        print "Installing $dist from local archive $dist_tarball_url\n";
        $dist_tarball_url =~ s/^file:\/+/\//;
        $dist_tarball_path = $dist_tarball_url;
    }
    else {
        print "Fetching $dist as $dist_tarball_path\n";
        $self->download($dist_tarball_url, $dist_tarball_path);
    }

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

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);
    return $extracted_dir;
}

sub do_install_blead {
    my $self = shift;
    my $dist = shift;

    my $dist_name           = 'perl';
    my $dist_git_describe   = 'blead';
    my $dist_version        = '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 = 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";
        }
    );


    # Returns the wrong extracted dir for blead
    $self->do_extract_tarball($dist_tarball_path);

    my $build_dir = joinpath($self->root, "build");
    local *DIRH;
    opendir DIRH, $build_dir or die "Couldn't open ${build_dir}: $!";
    my @contents = readdir DIRH;
    closedir DIRH or warn "Couldn't close ${build_dir}: $!";
    my @candidates = grep { m/^perl-[0-9a-f]{7,8}$/ } @contents;
    # Use a Schwartzian Transform in case there are lots of dirs that
    # look like "perl-$SHA1", which is what's inside blead.tar.gz,
    # so we stat each one only once.
    @candidates =   map  { $_->[0] }
                    sort { $b->[1] <=> $a->[1] } # descending
                    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_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 ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version);
    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 perl $dist_version as $dist_tarball_path\n" unless $self->{quiet};
        $self->download( $dist_tarball_url, $dist_tarball_path );
    }

    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($dist) {
        $self->run_command_help("install");
        exit(-1);
    }

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

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

        if ($version eq 'blead') {
            $self->do_install_blead($dist);
        }
        else {
            $self->do_install_release( $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 "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;
    }

    # 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;
{'fraction_non_alphanumeric': 0.1764362286970863, 'fraction_numerical': 0.008503985706432106, 'mean_word_length': 1.9809494546013213, 'pattern_counts': {'":': 0, '<': 49, '<?xml version=': 0, '>': 442, 'https://': 0, 'lorem ipsum': 0, 'www.': 10, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1414371', 'n_tokens_mistral': 21386, 'n_tokens_neox': 20305, 'n_words': 4856}