script.pm

package App::cpanminus::script;
use strict;
use Config;
use Cwd ();
use App::cpanminus;
use File::Basename ();
use File::Find ();
use File::Path ();
use File::Spec ();
use File::Copy ();
use File::Temp ();
use Getopt::Long ();
use Parse::CPAN::Meta;
use Symbol ();
use String::ShellQuote ();
use version ();

use aliased 'App::cpanminus::Dependency';

use constant WIN32 => $^O eq 'MSWin32';
use constant SUNOS => $^O eq 'solaris';

our $VERSION = $App::cpanminus::VERSION;

if ($INC{"App/FatPacker/Trace.pm"}) {
    require JSON::PP;
    require CPAN::Meta::YAML;
    require CPAN::Meta::Prereqs;
    require version::vpp;
    require File::pushd;
}

my $quote = WIN32 ? q/"/ : q/'/;

sub agent {
    my $self = shift;
    my $agent = "cpanminus/$VERSION";
    $agent .= " perl/$]" if $self->{report_perl_version};
    $agent;
}

sub determine_home {
    my $class = shift;

    my $homedir = $ENV{HOME}
      || eval { require File::HomeDir; File::HomeDir->my_home }
      || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32

    if (WIN32) {
        require Win32; # no fatpack
        $homedir = Win32::GetShortPathName($homedir);
    }

    return "$homedir/.cpanm";
}

sub new {
    my $class = shift;

    bless {
        home => $class->determine_home,
        cmd  => 'install',
        seen => {},
        notest => undef,
        test_only => undef,
        installdeps => undef,
        force => undef,
        sudo => undef,
        make  => undef,
        verbose => undef,
        quiet => undef,
        interactive => undef,
        log => undef,
        mirrors => [],
        mirror_only => undef,
        mirror_index => undef,
        perl => $^X,
        argv => [],
        local_lib => undef,
        self_contained => undef,
        prompt_timeout => 0,
        prompt => undef,
        configure_timeout => 60,
        build_timeout => 3600,
        test_timeout => 1800,
        try_lwp => 1,
        try_wget => 1,
        try_curl => 1,
        uninstall_shadows => ($] < 5.012),
        skip_installed => 1,
        skip_satisfied => 0,
        auto_cleanup => 7, # days
        pod2man => 1,
        installed_dists => 0,
        install_types => ['requires', 'recommends'],
        with_develop => 0,
        showdeps => 0,
        scandeps => 0,
        scandeps_tree => [],
        format   => 'tree',
        save_dists => undef,
        skip_configure => 0,
        verify => 0,
        report_perl_version => 1,
        build_args => {},
        features => {},
        @_,
    }, $class;
}

sub env {
    my($self, $key) = @_;
    $ENV{"PERL_CPANM_" . $key};
}

sub install_type_handlers {
    my $self = shift;

    my @handlers;
    for my $type (qw( recommends suggests )) {
        push @handlers, "with-$type" => sub {
            my %uniq;
            $self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ];
        };
        push @handlers, "without-$type" => sub {
            $self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ];
        };
    }

    @handlers;
}

sub build_args_handlers {
    my $self = shift;

    my @handlers;
    for my $phase (qw( configure build test install )) {
        push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
    }

    @handlers;
}

sub parse_options {
    my $self = shift;

    local @ARGV = @{$self->{argv}};
    push @ARGV, split /\s+/, $self->env('OPT');
    push @ARGV, @_;

    Getopt::Long::Configure("bundling");
    Getopt::Long::GetOptions(
        'f|force'   => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
        'n|notest!' => \$self->{notest},
        'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
        'S|sudo!'   => \$self->{sudo},
        'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
        'verify!'   => \$self->{verify},
        'q|quiet!'  => \$self->{quiet},
        'h|help'    => sub { $self->{action} = 'show_help' },
        'V|version' => sub { $self->{action} = 'show_version' },
        'perl=s'    => \$self->{perl},
        'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
        'L|local-lib-contained=s' => sub {
            $self->{local_lib} = $self->maybe_abs($_[1]);
            $self->{self_contained} = 1;
            $self->{pod2man} = undef;
        },
        'self-contained!' => \$self->{self_contained},
        'mirror=s@' => $self->{mirrors},
        'mirror-only!' => \$self->{mirror_only},
        'mirror-index=s'  => \$self->{mirror_index},
        'cascade-search!' => \$self->{cascade_search},
        'prompt!'   => \$self->{prompt},
        'installdeps' => \$self->{installdeps},
        'skip-installed!' => \$self->{skip_installed},
        'skip-satisfied!' => \$self->{skip_satisfied},
        'reinstall'    => sub { $self->{skip_installed} = 0 },
        'interactive!' => \$self->{interactive},
        'i|install' => sub { $self->{cmd} = 'install' },
        'info'      => sub { $self->{cmd} = 'info' },
        'look'      => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
        'self-upgrade' => sub { $self->check_upgrade; $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
        'uninst-shadows!'  => \$self->{uninstall_shadows},
        'lwp!'    => \$self->{try_lwp},
        'wget!'   => \$self->{try_wget},
        'curl!'   => \$self->{try_curl},
        'auto-cleanup=s' => \$self->{auto_cleanup},
        'man-pages!' => \$self->{pod2man},
        'scandeps'   => \$self->{scandeps},
        'showdeps'   => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
        'format=s'   => \$self->{format},
        'save-dists=s' => sub {
            $self->{save_dists} = $self->maybe_abs($_[1]);
        },
        'skip-configure!' => \$self->{skip_configure},
        'dev!'       => \$self->{dev_release},
        'metacpan!'  => \$self->{metacpan},
        'report-perl-version!' => \$self->{report_perl_version},
        'configure-timeout=i' => \$self->{configure_timeout},
        'build-timeout=i' => \$self->{build_timeout},
        'test-timeout=i' => \$self->{test_timeout},
        'with-develop' => \$self->{with_develop},
        'without-develop' => sub { $self->{with_develop} = 0 },
        'with-feature=s' => sub { $self->{features}{$_[1]} = 1 },
        'without-feature=s' => sub { $self->{features}{$_[1]} = 0 },
        'with-all-features' => sub { $self->{features}{__all} = 1 },
        $self->install_type_handlers,
        $self->build_args_handlers,
    );

    if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
        push @ARGV, $self->load_argv_from_fh(\*STDIN);
        $self->{load_from_stdin} = 1;
    }

    $self->{argv} = \@ARGV;
}

sub check_upgrade {
    if ($0 !~ /^$Config{installsitebin}/) {
        if ($0 =~ m!perlbrew/bin!) {
            warn <<WARN;
It appears your cpanm executable was installed via `perlbrew install-cpanm`.
cpanm --self-upgrade won't upgrade the version of cpanm you're running.

Run the following command to get it upgraded.

  perlbrew install-cpanm

WARN
        } else {
            warn <<WARN;
You are running cpanm from the path where your current perl won't install executables to.
Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.

  cpanm path   : $0
  Install path : $Config{installsitebin}

It means you either installed cpanm globally with system perl, or use distro packages such
as rpm or apt-get, and you have to use them again to upgrade cpanm.
WARN
        }
    }
}

sub check_libs {
    my $self = shift;
    return if $self->{_checked}++;

    $self->bootstrap_local_lib;
    if (@{$self->{bootstrap_deps} || []}) {
        local $self->{notest} = 1; # test failure in bootstrap should be tolerated
        local $self->{scandeps} = 0;
        $self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
    }
}

sub setup_verify {
    my $self = shift;

    my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
    $self->{cpansign} = $self->which('cpansign');

    unless ($has_modules && $self->{cpansign}) {
        warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
        $self->{verify} = 0;
    }
}

sub parse_module_args {
    my($self, $module) = @_;

    # Plack@1.2 -> Plack~"==1.2"
    # BUT don't expand @ in git URLs
    $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;

    # Plack~1.20, DBI~"> 1.0, <= 2.0"
    if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
        return split /\~/, $module, 2;
    } else {
        return $module, undef;
    }
}

sub doit {
    my $self = shift;

    $self->setup_home;
    $self->init_tools;
    $self->setup_verify if $self->{verify};

    if (my $action = $self->{action}) {
        $self->$action() and return 1;
    }

    $self->show_help(1)
        unless @{$self->{argv}} or $self->{load_from_stdin};

    $self->configure_mirrors;

    my $cwd = Cwd::cwd;

    my @fail;
    for my $module (@{$self->{argv}}) {
        if ($module =~ s/\.pm$//i) {
            my ($volume, $dirs, $file) = File::Spec->splitpath($module);
            $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
        }

        ($module, my $version) = $self->parse_module_args($module);

        $self->chdir($cwd);
        $self->install_module($module, 0, $version)
            or push @fail, $module;
    }

    if ($self->{base} && $self->{auto_cleanup}) {
        $self->cleanup_workdirs;
    }

    if ($self->{installed_dists}) {
        my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
        $self->diag("$self->{installed_dists} $dists installed\n", 1);
    }

    if ($self->{scandeps}) {
        $self->dump_scandeps();
    }
    # Workaround for older File::Temp's
    # where creating a tempdir with an implicit $PWD
    # causes tempdir non-cleanup if $PWD changes
    # as paths are stored internally without being resolved
    # absolutely.
    # https://rt.cpan.org/Public/Bug/Display.html?id=44924
    $self->chdir($cwd);

    return !@fail;
}

sub setup_home {
    my $self = shift;

    $self->{home} = $self->env('HOME') if $self->env('HOME');

    unless (_writable($self->{home})) {
        die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
    }

    $self->{base} = "$self->{home}/work/" . time . ".$$";
    File::Path::mkpath([ $self->{base} ], 0, 0777);

    my $link = "$self->{home}/latest-build";
    eval { unlink $link; symlink $self->{base}, $link };

    $self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect

    {
        my $log = $self->{log}; my $base = $self->{base};
        $self->{at_exit} = sub {
            my $self = shift;
            File::Copy::copy($self->{log}, "$self->{base}/build.log");
        };
    }

    { open my $out, ">$self->{log}" or die "$self->{log}: $!" }

    $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
                "Work directory is $self->{base}\n");
}

sub fetch_meta_sco {
    my($self, $dist) = @_;
    return if $self->{mirror_only};

    my $meta_yml = $self->get("http://search.cpan.org/meta/$dist->{distvname}/META.yml");
    return $self->parse_meta_string($meta_yml);
}

sub package_index_for {
    my ($self, $mirror) = @_;
    return $self->source_for($mirror) . "/02packages.details.txt";
}

sub generate_mirror_index {
    my ($self, $mirror) = @_;
    my $file = $self->package_index_for($mirror);
    my $gz_file = $file . '.gz';
    my $index_mtime = (stat $gz_file)[9];

    unless (-e $file && (stat $file)[9] >= $index_mtime) {
        $self->chat("Uncompressing index file...\n");
        if (eval {require Compress::Zlib}) {
            my $gz = Compress::Zlib::gzopen($gz_file, "rb")
                or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return};
            open my $fh, '>', $file
                or do { $self->diag_fail("$! opening uncompressed index for write"); return };
            my $buffer;
            while (my $status = $gz->gzread($buffer)) {
                if ($status < 0) {
                    $self->diag_fail($gz->gzerror . " reading compressed index");
                    return;
                }
                print $fh $buffer;
            }
        } else {
            if (system("gunzip -c $gz_file > $file")) {
                $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
                return;
            }
        }
        utime $index_mtime, $index_mtime, $file;
    }
    return 1;
}

sub search_mirror_index {
    my ($self, $mirror, $module, $version) = @_;
    $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
}

sub search_mirror_index_file {
    my($self, $file, $module, $version) = @_;

    open my $fh, '<', $file or return;
    my $found;
    while (<$fh>) {
        if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) {
            $found = $self->cpan_module($module, $2, $1);
            last;
        }
    }

    return $found unless $self->{cascade_search};

    if ($found) {
        if ($self->satisfy_version($module, $found->{module_version}, $version)) {
            return $found;
        } else {
            $self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
        }
    }

    return;
}

sub with_version_range {
    my($self, $version) = @_;
    defined($version) && $version =~ /[<>=]/;
}

sub encode_json {
    my($self, $data) = @_;
    require JSON::PP;

    my $json = JSON::PP::encode_json($data);
    $json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
    $json;
}

# TODO extract this as a module?
sub version_to_query {
    my($self, $module, $version) = @_;

    require CPAN::Meta::Requirements;

    my $requirements = CPAN::Meta::Requirements->new;
    $requirements->add_string_requirement($module, $version || '0');

    my $req = $requirements->requirements_for_module($module);

    if ($req =~ s/^==\s*//) {
        return {
            term => { 'module.version' => $req },
        };
    } elsif ($req !~ /\s/) {
        return {
            range => { 'module.version_numified' => { 'gte' => $self->numify_ver($req) } },
        };
    } else {
        my %ops = qw(< lt <= lte > gt >= gte);
        my(%range, @exclusion);
        my @requirements = split /,\s*/, $req;
        for my $r (@requirements) {
            if ($r =~ s/^([<>]=?)\s*//) {
                $range{$ops{$1}} = $self->numify_ver($r);
            } elsif ($r =~ s/\!=\s*//) {
                push @exclusion, $self->numify_ver($r);
            }
        }

        my @filters= (
            { range => { 'module.version_numified' => \%range } },
        );

        if (@exclusion) {
            push @filters, {
                not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver($_) } } } @exclusion ] },
            };
        }

        return @filters;
    }
}

sub numify_ver {
    my($self, $ver) = @_;
    version->new($ver)->numify;
}

sub maturity_filter {
    my($self, $module, $version) = @_;

    my @filters;

    # TODO: dev release should be enabled per dist
    if (!$self->with_version_range($version) or $self->{dev_release}) {
        # backpan'ed dev release are considered "cancelled"
        push @filters, { not => { term => { status => 'backpan' } } };
    }

    unless ($self->{dev_release} or $version =~ /==/) {
        push @filters, { term => { maturity => 'released' } };
    }

    return @filters;
}

sub search_metacpan {
    my($self, $module, $version) = @_;

    require JSON::PP;

    $self->chat("Searching $module ($version) on metacpan ...\n");

    my $metacpan_uri = 'http://api.metacpan.org/v0';

    my @filter = $self->maturity_filter($module, $version);

    my $query = { filtered => {
        (@filter ? (filter => { and => \@filter }) : ()),
        query => { nested => {
            score_mode => 'max',
            path => 'module',
            query => { custom_score => {
                metacpan_script => "score_version_numified",
                query => { constant_score => {
                    filter => { and => [
                        { term => { 'module.authorized' => JSON::PP::true() } },
                        { term => { 'module.indexed' => JSON::PP::true() } },
                        { term => { 'module.name' => $module } },
                        $self->version_to_query($module, $version),
                    ] }
                } },
            } },
        } },
    } };

    my $module_uri = "$metacpan_uri/file/_search?source=";
    $module_uri .= $self->encode_json({
        query => $query,
        fields => [ 'release', 'module' ],
    });

    my($release, $module_version);

    my $module_json = $self->get($module_uri);
    my $module_meta = eval { JSON::PP::decode_json($module_json) };
    my $match = $module_meta ? $module_meta->{hits}{hits}[0]{fields} : undef;
    if ($match) {
        $release = $match->{release};
        my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0];
        $module_version = $module_matched->{version};
    }

    unless ($release) {
        $self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");
        return;
    }

    my $dist_uri = "$metacpan_uri/release/_search?source=";
    $dist_uri .= $self->encode_json({
        filter => {
            term => { 'release.name' => $release },
        },
        fields => [ 'download_url', 'stat', 'status' ],
    });

    my $dist_json = $self->get($dist_uri);
    my $dist_meta = eval { JSON::PP::decode_json($dist_json) };

    if ($dist_meta) {
        $dist_meta = $dist_meta->{hits}{hits}[0]{fields};
    }
    if ($dist_meta && $dist_meta->{download_url}) {
        (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
        local $self->{mirrors} = $self->{mirrors};
        if ($dist_meta->{status} eq 'backpan') {
            $self->{mirrors} = [ 'http://backpan.perl.org' ];
        } elsif ($dist_meta->{stat}{mtime} > time()-24*60*60) {
            $self->{mirrors} = [ 'http://cpan.metacpan.org' ];
        }
        return $self->cpan_module($module, $distfile, $module_version);
    }

    $self->diag_fail("Finding $module on metacpan failed.");
    return;
}

sub search_database {
    my($self, $module, $version) = @_;

    my $found;
    my $range = ($self->with_version_range($version) || $self->{dev_release});

    if ($range or $self->{metacpan}) {
        $found = $self->search_metacpan($module, $version)   and return $found;
        $found = $self->search_cpanmetadb($module, $version) and return $found;
    } else {
        $found = $self->search_cpanmetadb($module, $version) and return $found;
        $found = $self->search_metacpan($module, $version)   and return $found;
    }
}

sub search_cpanmetadb {
    my($self, $module, $version) = @_;

    $self->chat("Searching $module on cpanmetadb ...\n");

    my $uri  = "http://cpanmetadb.plackperl.org/v1.0/package/$module";
    my $yaml = $self->get($uri);
    my $meta = $self->parse_meta_string($yaml);
    if ($meta && $meta->{distfile}) {
        return $self->cpan_module($module, $meta->{distfile}, $meta->{version});
    }

    $self->diag_fail("Finding $module on cpanmetadb failed.");
    return;
}

sub search_module {
    my($self, $module, $version) = @_;

    if ($self->{mirror_index}) {
        $self->chat("Searching $module on mirror index $self->{mirror_index} ...\n");
        my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version);
        return $pkg if $pkg;

        unless ($self->{cascade_search}) {
           $self->diag_fail("Finding $module ($version) on mirror index $self->{mirror_index} failed.");
           return;
        }
    }

    unless ($self->{mirror_only}) {
        my $found = $self->search_database($module, $version);
        return $found if $found;
    }

    MIRROR: for my $mirror (@{ $self->{mirrors} }) {
        $self->chat("Searching $module on mirror $mirror ...\n");
        my $name = '02packages.details.txt.gz';
        my $uri  = "$mirror/modules/$name";
        my $gz_file = $self->package_index_for($mirror) . '.gz';

        unless ($self->{pkgs}{$uri}) {
            $self->chat("Downloading index file $uri ...\n");
            $self->mirror($uri, $gz_file);
            $self->generate_mirror_index($mirror) or next MIRROR;
            $self->{pkgs}{$uri} = "!!retrieved!!";
        }

        my $pkg = $self->search_mirror_index($mirror, $module, $version);
        return $pkg if $pkg;

        $self->diag_fail("Finding $module ($version) on mirror $mirror failed.");
    }

    return;
}

sub source_for {
    my($self, $mirror) = @_;
    $mirror =~ s/[^\w\.\-]+/%/g;

    my $dir = "$self->{home}/sources/$mirror";
    File::Path::mkpath([ $dir ], 0, 0777);

    return $dir;
}

sub load_argv_from_fh {
    my($self, $fh) = @_;

    my @argv;
    while(defined(my $line = <$fh>)){
        chomp $line;
        $line =~ s/#.+$//; # comment
        $line =~ s/^\s+//; # trim spaces
        $line =~ s/\s+$//; # trim spaces

        push @argv, split ' ', $line if $line;
    }
    return @argv;
}

sub show_version {
    my $self = shift;

    print "cpanm (App::cpanminus) version $VERSION ($0)\n";
    print "perl version $] ($^X)\n\n";

    print "  \%Config:\n";
    for my $key (qw( archname installsitelib installsitebin installman1dir installman3dir
                     sitelibexp archlibexp privlibexp )) {
        print "    $key=$Config{$key}\n";
    }

    print "  \%ENV:\n";
    for my $key (grep /^PERL/, sort keys %ENV) {
        print "    $key=$ENV{$key}\n";
    }

    print "  \@INC:\n";
    for my $inc (@INC) {
        print "    $inc\n";
    }

    return 1;
}

sub show_help {
    my $self = shift;

    if ($_[0]) {
        die <<USAGE;
Usage: cpanm [options] Module [...]

Try `cpanm --help` or `man cpanm` for more options.
USAGE
    }

    print <<HELP;
Usage: cpanm [options] Module [...]

Options:
  -v,--verbose              Turns on chatty output
  -q,--quiet                Turns off the most output
  --interactive             Turns on interactive configure (required for Task:: modules)
  -f,--force                force install
  -n,--notest               Do not run unit tests
  --test-only               Run tests only, do not install
  -S,--sudo                 sudo to run install commands
  --installdeps             Only install dependencies
  --showdeps                Only display direct dependencies
  --reinstall               Reinstall the distribution even if you already have the latest version installed
  --mirror                  Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
  --mirror-only             Use the mirror's index file instead of the CPAN Meta DB
  --prompt                  Prompt when configure/build/test fails
  -l,--local-lib            Specify the install base to install modules
  -L,--local-lib-contained  Specify the install base to install all non-core modules
  --self-contained          Install all non-core modules, even if they're already installed.
  --auto-cleanup            Number of days that cpanm's work directories expire in. Defaults to 7

Commands:
  --self-upgrade            upgrades itself
  --info                    Displays distribution info on CPAN
  --look                    Opens the distribution with your SHELL
  -V,--version              Displays software version

Examples:

  cpanm Test::More                                          # install Test::More
  cpanm MIYAGAWA/Plack-0.99_05.tar.gz                       # full distribution path
  cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz           # install from URL
  cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz            # install from a local file
  cpanm --interactive Task::Kensho                          # Configure interactively
  cpanm .                                                   # install from local directory
  cpanm --installdeps .                                     # install all the deps for the current directory
  cpanm -L extlib Plack                                     # install Plack and all non-core deps into extlib
  cpanm --mirror http://cpan.cpantesters.org/ DBI           # use the fast-syncing mirror

You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:

  export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"

Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.

HELP

    return 1;
}

sub _writable {
    my $dir = shift;
    my @dir = File::Spec->splitdir($dir);
    while (@dir) {
        $dir = File::Spec->catdir(@dir);
        if (-e $dir) {
            return -w _;
        }
        pop @dir;
    }

    return;
}

sub maybe_abs {
    my($self, $lib) = @_;
    if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
        return $lib;
    } else {
        return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
    }
}

sub bootstrap_local_lib {
    my $self = shift;

    # If -l is specified, use that.
    if ($self->{local_lib}) {
        return $self->setup_local_lib($self->{local_lib});
    }

    # root, locally-installed perl or --sudo: don't care about install_base
    return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));

    # local::lib is configured in the shell -- yay
    if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
        $self->bootstrap_local_lib_deps;
        return;
    }

    $self->setup_local_lib;

    $self->diag(<<DIAG);
!
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
! To turn off this warning, you have to do one of the following:
!   - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
!   - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc.
!   - Install local::lib by running the following commands
!
!         cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
!
DIAG
    sleep 2;
}

sub _core_only_inc {
    my($self, $base) = @_;
    require local::lib;
    (
        local::lib->resolve_path(local::lib->install_base_perl_path($base)),
        local::lib->resolve_path(local::lib->install_base_arch_path($base)),
        @Config{qw(privlibexp archlibexp)},
    );
}

sub _diff {
    my($self, $old, $new) = @_;

    my @diff;
    my %old = map { $_ => 1 } @$old;
    for my $n (@$new) {
        push @diff, $n unless exists $old{$n};
    }

    @diff;
}

sub _setup_local_lib_env {
    my($self, $base) = @_;
    local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
    local::lib->setup_env_hash_for($base);
}

sub setup_local_lib {
    my($self, $base) = @_;
    $base = undef if $base eq '_';

    require local::lib;
    {
        local $0 = 'cpanm'; # so curl/wget | perl works
        $base ||= "~/perl5";
        $base = local::lib->resolve_path($base);
        if ($self->{self_contained}) {
            my @inc = $self->_core_only_inc($base);
            $self->{search_inc} = [ @inc ];
        } else {
            $self->{search_inc} = [
                local::lib->install_base_arch_path($base),
                local::lib->install_base_perl_path($base),
                @INC,
            ];
        }
        $self->_setup_local_lib_env($base);
    }

    $self->bootstrap_local_lib_deps;
}

sub bootstrap_local_lib_deps {
    my $self = shift;
    push @{$self->{bootstrap_deps}},
        Dependency->new('ExtUtils::MakeMaker' => 6.31),
        Dependency->new('ExtUtils::Install'   => 1.46);
}

sub prompt_bool {
    my($self, $mess, $def) = @_;

    my $val = $self->prompt($mess, $def);
    return lc $val eq 'y';
}

sub prompt {
    my($self, $mess, $def) = @_;

    my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
    my $dispdef = defined $def ? "[$def] " : " ";
    $def = defined $def ? $def : "";

    if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
        return $def;
    }

    local $|=1;
    local $\;
    my $ans;
    eval {
        local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
        print STDOUT "$mess $dispdef";
        alarm $self->{prompt_timeout} if $self->{prompt_timeout};
        $ans = <STDIN>;
        alarm 0;
    };
    if ( defined $ans ) {
        chomp $ans;
    } else { # user hit ctrl-D or alarm timeout
        print STDOUT "\n";
    }

    return (!defined $ans || $ans eq '') ? $def : $ans;
}

sub diag_ok {
    my($self, $msg) = @_;
    chomp $msg;
    $msg ||= "OK";
    if ($self->{in_progress}) {
        $self->_diag("$msg\n");
        $self->{in_progress} = 0;
    }
    $self->log("-> $msg\n");
}

sub diag_fail {
    my($self, $msg, $always) = @_;
    chomp $msg;
    if ($self->{in_progress}) {
        $self->_diag("FAIL\n");
        $self->{in_progress} = 0;
    }

    if ($msg) {
        $self->_diag("! $msg\n", $always);
        $self->log("-> FAIL $msg\n");
    }
}

sub diag_progress {
    my($self, $msg) = @_;
    chomp $msg;
    $self->{in_progress} = 1;
    $self->_diag("$msg ... ");
    $self->log("$msg\n");
}

sub _diag {
    my($self, $msg, $always) = @_;
    print STDERR $msg if $always or $self->{verbose} or !$self->{quiet};
}

sub diag {
    my($self, $msg, $always) = @_;
    $self->_diag($msg, $always);
    $self->log($msg);
}

sub chat {
    my $self = shift;
    print STDERR @_ if $self->{verbose};
    $self->log(@_);
}

sub log {
    my $self = shift;
    open my $out, ">>$self->{log}";
    print $out @_;
}

sub run {
    my($self, $cmd) = @_;

    if (WIN32) {
        $cmd = $self->shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
        unless ($self->{verbose}) {
            $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
        }
        !system $cmd;
    } else {
        my $pid = fork;
        if ($pid) {
            waitpid $pid, 0;
            return !$?;
        } else {
            $self->run_exec($cmd);
        }
    }
}

sub run_exec {
    my($self, $cmd) = @_;

    if (ref $cmd eq 'ARRAY') {
        unless ($self->{verbose}) {
            open my $logfh, ">>", $self->{log};
            open STDERR, '>&', $logfh;
            open STDOUT, '>&', $logfh;
            close $logfh;
        }
        exec @$cmd;
    } else {
        unless ($self->{verbose}) {
            $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
        }
        exec $cmd;
    }
}

sub run_timeout {
    my($self, $cmd, $timeout) = @_;
    return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout;

    my $pid = fork;
    if ($pid) {
        eval {
            local $SIG{ALRM} = sub { die "alarm\n" };
            alarm $timeout;
            waitpid $pid, 0;
            alarm 0;
        };
        if ($@ && $@ eq "alarm\n") {
            $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");
            local $SIG{TERM} = 'IGNORE';
            kill TERM => 0;
            waitpid $pid, 0;
            return;
        }
        return !$?;
    } elsif ($pid == 0) {
        $self->run_exec($cmd);
    } else {
        $self->chat("! fork failed: falling back to system()\n");
        $self->run($cmd);
    }
}

sub append_args {
    my($self, $cmd, $phase) = @_;

    if (my $args = $self->{build_args}{$phase}) {
        $cmd = join ' ', $self->shell_quote(@$cmd), $args;
    }

    $cmd;
}

sub configure {
    my($self, $cmd, $depth) = @_;

    # trick AutoInstall
    local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;

    # e.g. skip CPAN configuration on local::lib
    local $ENV{PERL5_CPANM_IS_RUNNING} = $$;

    my $use_default = !$self->{interactive};
    local $ENV{PERL_MM_USE_DEFAULT} = $use_default;

    # skip man page generation
    local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
    unless ($self->{pod2man}) {
        $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
        $ENV{PERL_MB_OPT} .= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir=";
    }

    $cmd = $self->append_args($cmd, 'configure') if $depth == 0;

    local $self->{verbose} = $self->{verbose} || $self->{interactive};
    $self->run_timeout($cmd, $self->{configure_timeout});
}

sub build {
    my($self, $cmd, $distname, $depth) = @_;

    local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};

    $cmd = $self->append_args($cmd, 'build') if $depth == 0;

    return 1 if $self->run_timeout($cmd, $self->{build_timeout});
    while (1) {
        my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
        return                                       if $ans eq 's';
        return $self->build($cmd, $distname, $depth) if $ans eq 'r';
        $self->show_build_log                        if $ans eq 'e';
        $self->look                                  if $ans eq 'l';
    }
}

sub test {
    my($self, $cmd, $distname, $depth) = @_;
    return 1 if $self->{notest};

    # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
    local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};

    $cmd = $self->append_args($cmd, 'test') if $depth == 0;

    return 1 if $self->run_timeout($cmd, $self->{test_timeout});
    if ($self->{force}) {
        $self->diag_fail("Testing $distname failed but installing it anyway.");
        return 1;
    } else {
        $self->diag_fail;
        while (1) {
            my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s");
            return                                      if $ans eq 's';
            return $self->test($cmd, $distname, $depth) if $ans eq 'r';
            return 1                                    if $ans eq 'f';
            $self->show_build_log                       if $ans eq 'e';
            $self->look                                 if $ans eq 'l';
        }
    }
}

sub install {
    my($self, $cmd, $uninst_opts, $depth) = @_;

    if ($depth == 0 && $self->{test_only}) {
        return 1;
    }

    if ($self->{sudo}) {
        unshift @$cmd, "sudo";
    }

    if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
        push @$cmd, @$uninst_opts;
    }

    $cmd = $self->append_args($cmd, 'install') if $depth == 0;

    $self->run($cmd);
}

sub look {
    my $self = shift;

    my $shell = $ENV{SHELL};
    $shell  ||= $ENV{COMSPEC} if WIN32;
    if ($shell) {
        my $cwd = Cwd::cwd;
        $self->diag("Entering $cwd with $shell\n");
        system $shell;
    } else {
        $self->diag_fail("You don't seem to have a SHELL :/");
    }
}

sub show_build_log {
    my $self = shift;

    my @pagers = (
        $ENV{PAGER},
        (WIN32 ? () : ('less')),
        'more'
    );
    my $pager;
    while (@pagers) {
        $pager = shift @pagers;
        next unless $pager;
        $pager = $self->which($pager);
        next unless $pager;
        last;
    }

    if ($pager) {
        # win32 'more' doesn't allow "more build.log", the < is required
        system("$pager < $self->{log}");
    }
    else {
        $self->diag_fail("You don't seem to have a PAGER :/");
    }
}

sub chdir {
    my $self = shift;
    Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
}

sub configure_mirrors {
    my $self = shift;
    unless (@{$self->{mirrors}}) {
        $self->{mirrors} = [ 'http://www.cpan.org' ];
    }
    for (@{$self->{mirrors}}) {
        s!^/!file:///!;
        s!/$!!;
    }
}

sub self_upgrade {
    my $self = shift;
    $self->{argv} = [ 'App::cpanminus' ];
    return; # continue
}

sub install_module {
    my($self, $module, $depth, $version) = @_;

    if ($self->{seen}{$module}++) {
        $self->chat("Already tried $module. Skipping.\n");
        return 1;
    }

    $self->check_libs;

    if ($self->{skip_satisfied}) {
        my($ok, $local) = $self->check_module($module, $version || 0);
        if ($ok) {
            $self->diag("You have $module ($local)\n", 1);
            return 1;
        }
    }

    my $dist = $self->resolve_name($module, $version);
    unless ($dist) {
        $self->diag_fail("Couldn't find module or a distribution $module ($version)", 1);
        return;
    }

    if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
        $self->chat("Already tried $dist->{distvname}. Skipping.\n");
        return 1;
    }

    if ($self->{cmd} eq 'info') {
        print $self->format_dist($dist), "\n";
        return 1;
    }

    $dist->{depth} = $depth; # ugly hack

    if ($dist->{module}) {
        # check if we already have the exact same version
        my $requirement = $dist->{module_version} ? "==$dist->{module_version}" : 0;
        my($ok, $local) = $self->check_module($dist->{module}, $requirement);
        if ($self->{skip_installed} && $ok) {
            $self->diag("$dist->{module} is up to date. ($local)\n", 1);
            return 1;
        }

        unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) {
            $self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n");
            return;
        }
    }

    if ($dist->{dist} eq 'perl'){
        $self->diag("skipping $dist->{pathname}\n");
        return 1;
    }

    $self->diag("--> Working on $module\n");

    $dist->{dir} ||= $self->fetch_module($dist);

    unless ($dist->{dir}) {
        $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
        return;
    }

    $self->chat("Entering $dist->{dir}\n");
    $self->chdir($self->{base});
    $self->chdir($dist->{dir});

    if ($self->{cmd} eq 'look') {
        $self->look;
        return 1;
    }

    return $self->build_stuff($module, $dist, $depth);
}

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

    # TODO support --dist-format?
    return "$dist->{cpanid}/$dist->{filename}";
}

sub trim {
    local $_ = shift;
    tr/\n/ /d;
    s/^\s*|\s*$//g;
    $_;
}

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

    $self->chdir($self->{base});

    for my $uri (@{$dist->{uris}}) {
        $self->diag_progress("Fetching $uri");

        # Ugh, $dist->{filename} can contain sub directory
        my $filename = $dist->{filename} || $uri;
        my $name = File::Basename::basename($filename);

        my $cancelled;
        my $fetch = sub {
            my $file;
            eval {
                local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
                $self->mirror($uri, $name);
                $file = $name if -e $name;
            };
            $self->diag("ERROR: " . trim("$@") . "\n", 1) if $@ && $@ ne "SIGINT\n";
            return $file;
        };

        my($try, $file);
        while ($try++ < 3) {
            $file = $fetch->();
            last if $cancelled or $file;
            $self->diag_fail("Download $uri failed. Retrying ... ");
        }

        if ($cancelled) {
            $self->diag_fail("Download cancelled.");
            return;
        }

        unless ($file) {
            $self->diag_fail("Failed to download $uri");
            next;
        }

        $self->diag_ok;
        $dist->{local_path} = File::Spec->rel2abs($name);

        my $dir = $self->unpack($file, $uri, $dist);
        next unless $dir; # unpack failed

        if (my $save = $self->{save_dists}) {
            # Only distros retrieved from CPAN have a pathname set
            my $path = $dist->{pathname} ? "$save/authors/id/$dist->{pathname}"
                                         : "$save/vendor/$file";
            $self->chat("Copying $name to $path\n");
            File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
            File::Copy::copy($file, $path) or warn $!;
        }

        return $dist, $dir;
    }
}

sub unpack {
    my($self, $file, $uri, $dist) = @_;

    if ($self->{verify}) {
        $self->verify_archive($file, $uri, $dist) or return;
    }

    $self->chat("Unpacking $file\n");
    my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
    unless ($dir) {
        $self->diag_fail("Failed to unpack $file: no directory");
    }
    return $dir;
}

sub verify_checksums_signature {
    my($self, $chk_file) = @_;

    require Module::Signature; # no fatpack

    $self->chat("Verifying the signature of CHECKSUMS\n");

    my $rv = eval {
        local $SIG{__WARN__} = sub {}; # suppress warnings
        my $v = Module::Signature::_verify($chk_file);
        $v == Module::Signature::SIGNATURE_OK();
    };
    if ($rv) {
        $self->chat("Verified OK!\n");
    } else {
        $self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");
        return;
    }

    return 1;
}

sub verify_archive {
    my($self, $file, $uri, $dist) = @_;

    unless ($dist->{cpanid}) {
        $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
    }

    (my $mirror = $uri) =~ s!/authors/id.*$!!;

    (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
    my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
    $self->diag_progress("Fetching $chksum_uri");
    $self->mirror($chksum_uri, $chk_file);

    unless (-e $chk_file) {
        $self->diag_fail("Fetching $chksum_uri failed.\n");
        return;
    }

    $self->diag_ok;
    $self->verify_checksums_signature($chk_file) or return;
    $self->verify_checksum($file, $chk_file);
}

sub verify_checksum {
    my($self, $file, $chk_file) = @_;

    $self->chat("Verifying the SHA1 for $file\n");

    open my $fh, "<$chk_file" or die "$chk_file: $!";
    my $data = join '', <$fh>;
    $data =~ s/\015?\012/\n/g;

    require Safe; # no fatpack
    my $chksum = Safe->new->reval($data);

    if (!ref $chksum or ref $chksum ne 'HASH') {
        $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
        return;
    }

    if (my $sha = $chksum->{$file}{sha256}) {
        my $hex = $self->sha1_for($file);
        if ($hex eq $sha) {
            $self->chat("Checksum for $file: Verified!\n");
        } else {
            $self->diag_fail("Checksum mismatch for $file\n");
            return;
        }
    } else {
        $self->chat("Checksum for $file not found in CHECKSUMS.\n");
        return;
    }
}

sub sha1_for {
    my($self, $file) = @_;

    require Digest::SHA; # no fatpack

    open my $fh, "<", $file or die "$file: $!";
    my $dg = Digest::SHA->new(256);
    my($data);
    while (read($fh, $data, 4096)) {
        $dg->add($data);
    }

    return $dg->hexdigest;
}

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

    $self->diag_progress("Verifying the SIGNATURE file");
    my $out = `$self->{cpansign} -v --skip 2>&1`;
    $self->log($out);

    if ($out =~ /Signature verified OK/) {
        $self->diag_ok("Verified OK");
        return 1;
    } else {
        $self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n");
        return;
    }
}

sub resolve_name {
    my($self, $module, $version) = @_;

    # URL
    if ($module =~ /^(ftp|https?|file):/) {
        if ($module =~ m!authors/id/(.*)!) {
            return $self->cpan_dist($1, $module);
        } else {
            return { uris => [ $module ] };
        }
    }

    # Directory
    if ($module =~ m!^[\./]! && -d $module) {
        return {
            source => 'local',
            dir => Cwd::abs_path($module),
        };
    }

    # File
    if (-f $module) {
        return {
            source => 'local',
            uris => [ "file://" . Cwd::abs_path($module) ],
        };
    }

    # Git
    if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) {
        return $self->git_uri($module);
    }

    # cpan URI
    if ($module =~ s!^cpan:///distfile/!!) {
        return $self->cpan_dist($module);
    }

    # PAUSEID/foo
    # P/PA/PAUSEID/foo
    if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2,}/.*)$!) {
        return $self->cpan_dist($1);
    }

    # Module name
    return $self->search_module($module, $version);
}

sub cpan_module {
    my($self, $module, $dist, $version) = @_;

    my $dist = $self->cpan_dist($dist);
    $dist->{module} = $module;
    $dist->{module_version} = $version if $version && $version ne 'undef';

    return $dist;
}

sub cpan_dist {
    my($self, $dist, $url) = @_;

    $dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;

    require CPAN::DistnameInfo;
    my $d = CPAN::DistnameInfo->new($dist);

    if ($url) {
        $url = [ $url ] unless ref $url eq 'ARRAY';
    } else {
        my $id = $d->cpanid;
        my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;

        my @mirrors = @{$self->{mirrors}};
        my @urls    = map "$_/authors/id/$fn", @mirrors;

        $url = \@urls,
    }

    return {
        $d->properties,
        source  => 'cpan',
        uris    => $url,
    };
}

sub git_uri {
    my ($self, $uri) = @_;

    # similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support
    # git URL has to end with .git when you need to use pin @ commit/tag/branch

    ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;

    my $dir = File::Temp::tempdir(CLEANUP => 1);

    $self->diag_progress("Cloning $uri");
    $self->run([ 'git', 'clone', $uri, $dir ]);

    unless (-e "$dir/.git") {
        $self->diag_fail("Failed cloning git repository $uri");
        return;
    }

    if ($commitish) {
        require File::pushd;
        my $dir = File::pushd::pushd($dir);

        unless ($self->run([ 'git', 'checkout', $commitish ])) {
            $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
            return;
        }
    }

    $self->diag_ok;

    return {
        source => 'local',
        dir    => $dir,
    };
}

sub setup_module_build_patch {
    my $self = shift;

    open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!;
    print $out <<EOF;
package ModuleBuildSkipMan;
CHECK {
  if (%Module::Build::) {
    no warnings 'redefine';
    *Module::Build::Base::ACTION_manpages = sub {};
    *Module::Build::Base::ACTION_docs     = sub {};
  }
}
1;
EOF
}

sub core_version_for {
    my($self, $module) = @_;

    require Module::CoreList; # no fatpack
    unless (exists $Module::CoreList::version{$]+0}) {
        die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
                    "You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
                    $Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
    }

    unless (exists $Module::CoreList::version{$]+0}{$module}) {
        return -1;
    }

    return $Module::CoreList::version{$]+0}{$module};
}


sub check_module {
    my($self, $mod, $want_ver) = @_;

    require Module::Metadata;
    my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
        or return 0, undef;

    my $version = $meta->version;

    # When -L is in use, the version loaded from 'perl' library path
    # might be newer than (or actually wasn't core at) the version
    # that is shipped with the current perl
    if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
        $version = $self->core_version_for($mod);
        return 0, undef if $version && $version == -1;
    }

    $self->{local_versions}{$mod} = $version;

    if ($self->is_deprecated($meta)){
        return 0, $version;
    } elsif ($self->satisfy_version($mod, $version, $want_ver)) {
        return 1, ($version || 'undef');
    } else {
        return 0, $version;
    }
}

sub satisfy_version {
    my($self, $mod, $version, $want_ver) = @_;

    $want_ver = '0' unless defined($want_ver) && length($want_ver);

    require CPAN::Meta::Requirements;
    my $requirements = CPAN::Meta::Requirements->new;
    $requirements->add_string_requirement($mod, $want_ver);
    $requirements->accepts_module($mod, $version);
}

sub unsatisfy_how {
    my($self, $ver, $want_ver) = @_;

    if ($want_ver =~ /^[v0-9\.\_]+$/) {
        return "$ver < $want_ver";
    } else {
        return "$ver doesn't satisfy $want_ver";
    }
}

sub is_deprecated {
    my($self, $meta) = @_;

    my $deprecated = eval {
        require Module::CoreList; # no fatpack
        Module::CoreList::is_deprecated($meta->{module});
    };

    return $deprecated && $self->loaded_from_perl_lib($meta);
}

sub loaded_from_perl_lib {
    my($self, $meta) = @_;

    require Config;
    for my $dir (qw(archlibexp privlibexp)) {
        my $confdir = $Config{$dir};
        if ($confdir eq substr($meta->filename, 0, length($confdir))) {
            return 1;
        }
    }

    return;
}

sub should_install {
    my($self, $mod, $ver) = @_;

    $self->chat("Checking if you have $mod $ver ... ");
    my($ok, $local) = $self->check_module($mod, $ver);

    if ($ok)       { $self->chat("Yes ($local)\n") }
    elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") }
    else           { $self->chat("No\n") }

    return $mod unless $ok;
    return;
}

sub check_perl_version {
    my($self, $version) = @_;
    require CPAN::Meta::Requirements;
    my $req = CPAN::Meta::Requirements->from_string_hash({ perl => $version });
    $req->accepts_module(perl => $]);
}

sub install_deps {
    my($self, $dir, $depth, @deps) = @_;

    my(@install, %seen, @fail);
    for my $dep (@deps) {
        next if $seen{$dep->module};
        if ($dep->module eq 'perl') {
            unless ($self->check_perl_version($dep->version)) {
                $self->diag("Needs perl @{[$dep->version]}, you have $]\n");
                push @fail, 'perl';
            }
        } elsif ($self->should_install($dep->module, $dep->version)) {
            push @install, $dep;
            $seen{$dep->module} = 1;
        }
    }

    if (@install) {
        $self->diag("==> Found dependencies: " . join(", ",  map $_->module, @install) . "\n");
    }

    for my $dep (@install) {
        unless ($self->install_module($dep->module, $depth + 1, $dep->version)) {
            push @fail, $dep->module if $dep->is_requirement;
        }
    }

    $self->chdir($self->{base});
    $self->chdir($dir) if $dir;

    return @fail;
}

sub install_deps_bailout {
    my($self, $target, $dir, $depth, @deps) = @_;

    my @fail = $self->install_deps($dir, $depth, @deps);
    if (@fail) {
        unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " .
                                   join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) {
            $self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1);
            return;
        }
    }

    return 1;
}

sub build_stuff {
    my($self, $stuff, $dist, $depth) = @_;

    if ($self->{verify} && -e 'SIGNATURE') {
        $self->verify_signature($dist) or return;
    }

    if (-e 'META.json') {
        $self->chat("Checking configure dependencies from META.json\n");
        $dist->{meta} = $self->parse_meta('META.json');
    } elsif (-e 'META.yml') {
        $self->chat("Checking configure dependencies from META.yml\n");
        $dist->{meta} = $self->parse_meta('META.yml');
    }

    if (!$dist->{meta} && $dist->{source} eq 'cpan') {
        $self->chat("META.yml/json not found or unparsable. Fetching META.yml from search.cpan.org\n");
        $dist->{meta} = $self->fetch_meta_sco($dist);
    }

    $dist->{meta} ||= {};

    if ($dist->{meta}{'meta-spec'}) {
        require CPAN::Meta;
        $dist->{cpanmeta} = CPAN::Meta->new($dist->{meta}, { lazy_validation => 1 });
    }

    my @config_deps;

    if ($dist->{cpanmeta}) {
        push @config_deps, Dependency->from_prereqs(
            $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
        );
    } else {
        push @config_deps, Dependency->from_versions(
            $dist->{meta}{configure_requires} || {}, 'configure',
        );
    }

    my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};

    $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
        or return;

    $self->diag_progress("Configuring $target");

    my $configure_state = $self->configure_this($dist, $depth);

    $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");

    # install direct 'test' dependencies for --installdeps, even with --notest
    my $root_target = (($self->{installdeps} or $self->{showdeps}) and $depth == 0);
    $dist->{want_phases} = $self->{notest} && !$root_target
                         ? [qw( build runtime )] : [qw( build test runtime )];

    push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;

    my @deps = $self->find_prereqs($dist);
    my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
    $module_name =~ s/-/::/g;

    if ($self->{showdeps}) {
        for my $dep (@config_deps, @deps) {
            print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
        }
        return 1;
    }

    my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;

    my $walkup;
    if ($self->{scandeps}) {
        $walkup = $self->scandeps_append_child($dist);
    }

    $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
        or return;

    if ($self->{scandeps}) {
        unless ($configure_state->{configured_ok}) {
            my $diag = <<DIAG;
! Configuring $distname failed. See $self->{log} for details.
! You might have to install the following modules first to get --scandeps working correctly.
DIAG
            if (@config_deps) {
                my @tree = @{$self->{scandeps_tree}};
                $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
            }
            $self->diag("!\n$diag!\n", 1);
        }
        $walkup->();
        return 1;
    }

    if ($self->{installdeps} && $depth == 0) {
        if ($configure_state->{configured_ok}) {
            $self->diag("<== Installed dependencies for $stuff. Finishing.\n");
            return 1;
        } else {
            $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
            return;
        }
    }

    my $installed;
    if ($configure_state->{use_module_build} && -e 'Build' && -f _) {
        $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
        $self->build([ $self->{perl}, "./Build" ], $distname, $depth) &&
        $self->test([ $self->{perl}, "./Build", "test" ], $distname, $depth) &&
        $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $depth) &&
        $installed++;
    } elsif ($self->{make} && -e 'Makefile') {
        $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
        $self->build([ $self->{make} ], $distname, $depth) &&
        $self->test([ $self->{make}, "test" ], $distname, $depth) &&
        $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) &&
        $installed++;
    } else {
        my $why;
        my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
        if ($configure_failed) { $why = "Configure failed for $distname." }
        elsif ($self->{make})  { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
        else                   { $why = "Can't configure the distribution. You probably need to have 'make'." }

        $self->diag_fail("$why See $self->{log} for details.", 1);
        return;
    }

    if ($installed && $self->{test_only}) {
        $self->diag_ok;
        $self->diag("Successfully tested $distname\n", 1);
    } elsif ($installed) {
        my $local   = $self->{local_versions}{$dist->{module} || ''};
        my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version};
        my $reinstall = $local && ($local eq $version);

        my $how = $reinstall ? "reinstalled $distname"
                : $local     ? "installed $distname (upgraded from $local)"
                             : "installed $distname" ;
        my $msg = "Successfully $how";
        $self->diag_ok;
        $self->diag("$msg\n", 1);
        $self->{installed_dists}++;
        $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
        return 1;
    } else {
        my $what = $self->{test_only} ? "Testing" : "Installing";
        $self->diag_fail("$what $stuff failed. See $self->{log} for details.", 1);
        return;
    }
}

sub perl_requirements {
    my($self, @requires) = @_;

    my @perl;
    for my $requires (grep defined, @requires) {
        if (exists $requires->{perl}) {
            push @perl, Dependency->new(perl => $requires->{perl});
        }
    }

    return @perl;
}

sub configure_this {
    my($self, $dist, $depth) = @_;

    if (-e 'cpanfile' && $self->{installdeps} && $depth == 0) {
        require Module::CPANfile;
        $dist->{cpanfile} = eval { Module::CPANfile->load('cpanfile') };
        $self->diag_fail($@, 1) if $@;
        return {
            configured       => 1,
            configured_ok    => !!$dist->{cpanfile},
            use_module_build => 0,
        };
    }

    if ($self->{skip_configure}) {
        my $eumm = -e 'Makefile';
        my $mb   = -e 'Build' && -f _;
        return {
            configured => 1,
            configured_ok => $eumm || $mb,
            use_module_build => $mb,
        };
    }

    my $state = {};

    my $try_eumm = sub {
        if (-e 'Makefile.PL') {
            $self->chat("Running Makefile.PL\n");

            # NOTE: according to Devel::CheckLib, most XS modules exit
            # with 0 even if header files are missing, to avoid receiving
            # tons of FAIL reports in such cases. So exit code can't be
            # trusted if it went well.
            if ($self->configure([ $self->{perl}, "Makefile.PL" ], $depth)) {
                $state->{configured_ok} = -e 'Makefile';
            }
            $state->{configured}++;
        }
    };

    my $try_mb = sub {
        if (-e 'Build.PL') {
            $self->chat("Running Build.PL\n");
            if ($self->configure([ $self->{perl}, "Build.PL" ], $depth)) {
                $state->{configured_ok} = -e 'Build' && -f _;
            }
            $state->{use_module_build}++;
            $state->{configured}++;
        }
    };

    # Module::Build deps should use MakeMaker because that causes circular deps and fail
    # Otherwise we should prefer Build.PL
    my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest );

    my @try;
    if ($dist->{dist} && $should_use_mm{$dist->{dist}}) {
        @try = ($try_eumm, $try_mb);
    } else {
        @try = ($try_mb, $try_eumm);
    }

    for my $try (@try) {
        $try->();
        last if $state->{configured_ok};
    }

    unless ($state->{configured_ok}) {
        while (1) {
            my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
            last                                        if $ans eq 's';
            return $self->configure_this($dist, $depth) if $ans eq 'r';
            $self->show_build_log                       if $ans eq 'e';
            $self->look                                 if $ans eq 'l';
        }
    }

    return $state;
}

sub find_module_name {
    my($self, $state) = @_;

    return unless $state->{configured_ok};

    if ($state->{use_module_build} &&
        -e "_build/build_params") {
        my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) };
        return eval { $params->[2]{module_name} } || undef;
    } elsif (-e "Makefile") {
        open my $mf, "Makefile";
        while (<$mf>) {
            if (/^\#\s+NAME\s+=>\s+(.*)/) {
                return $self->safe_eval($1);
            }
        }
    }

    return;
}

sub save_meta {
    my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;

    return unless $dist->{distvname} && $dist->{source} eq 'cpan';

    my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
        ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};

    require Module::Metadata;
    my $provides = $self->_merge_hashref(
        map Module::Metadata->package_versions_from_directory($_),
            qw( blib/lib blib/arch ) # FCGI.pm :(
    );

    File::Path::mkpath("blib/meta", 0, 0777);

    my $local = {
        name => $module_name,
        target => $module,
        version => $provides->{$module_name}{version} || $dist->{version},
        dist => $dist->{distvname},
        pathname => $dist->{pathname},
        provides => $provides,
    };

    require JSON::PP;
    open my $fh, ">", "blib/meta/install.json" or die $!;
    print $fh JSON::PP::encode_json($local);

    # Existence of MYMETA.* Depends on EUMM/M::B versions and CPAN::Meta
    if (-e "MYMETA.json") {
        File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
    }

    my @cmd = (
        ($self->{sudo} ? 'sudo' : ()),
        $^X,
        '-MExtUtils::Install=install',
        '-e',
        qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
    );
    $self->run(\@cmd);
}

sub _merge_hashref {
    my($self, @hashrefs) = @_;

    my %hash;
    for my $h (@hashrefs) {
        %hash = (%hash, %$h);
    }

    return \%hash;
}

sub install_base {
    my($self, $mm_opt) = @_;
    $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
    die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
}

sub safe_eval {
    my($self, $code) = @_;
    eval $code;
}

sub configure_features {
    my($self, $dist, @features) = @_;
    map $_->identifier, grep { $self->effective_feature($dist, $_) } @features;
}

sub effective_feature {
    my($self, $dist, $feature) = @_;

    if ($dist->{depth} == 0) {
        my $value = $self->{features}{$feature->identifier};
        return $value if defined $value;
        return 1 if $self->{features}{__all};
    }

    if ($self->{interactive}) {
        require CPAN::Meta::Requirements;

        $self->diag("[@{[ $feature->description ]}]\n", 1);

        my $req = CPAN::Meta::Requirements->new;
        for my $phase (@{$dist->{want_phases}}) {
            for my $type (@{$self->{install_types}}) {
                $req->add_requirements($feature->prereqs->requirements_for($phase, $type));
            }
        }

        my $reqs = $req->as_string_hash;
        my @missing;
        for my $module (keys %$reqs) {
            if ($self->should_install($module, $req->{$module})) {
                push @missing, $module;
            }
        }

        if (@missing) {
            my $howmany = @missing;
            $self->diag("==> Found missing dependencies: " . join(", ", @missing) . "\n", 1);
            local $self->{prompt} = 1;
            return $self->prompt_bool("Install the $howmany optional module(s)?", "y");
        }
    }

    return;
}

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

    my @deps = $self->extract_meta_prereqs($dist);

    if ($dist->{module} =~ /^Bundle::/i) {
        push @deps, $self->bundle_deps($dist);
    }

    return @deps;
}

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

    if ($dist->{cpanfile}) {
        my @features = $self->configure_features($dist, $dist->{cpanfile}->features);
        my $prereqs = $dist->{cpanfile}->prereqs_with(@features);
        return Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
    }

    my $meta = $dist->{meta};

    my @deps;
    if (-e "MYMETA.json") {
        require JSON::PP;
        $self->chat("Checking dependencies from MYMETA.json ...\n");
        my $json = do { open my $in, "<MYMETA.json"; local $/; <$in> };
        my $mymeta = JSON::PP::decode_json($json);
        if ($mymeta) {
            $meta->{$_} = $mymeta->{$_} for qw(name version);
            return $self->extract_prereqs($mymeta, $dist);
        }
    }

    if (-e 'MYMETA.yml') {
        $self->chat("Checking dependencies from MYMETA.yml ...\n");
        my $mymeta = $self->parse_meta('MYMETA.yml');
        if ($mymeta) {
            $meta->{$_} = $mymeta->{$_} for qw(name version);
            return $self->extract_prereqs($mymeta, $dist);
        }
    }

    if (-e '_build/prereqs') {
        $self->chat("Checking dependencies from _build/prereqs ...\n");
        my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
        @deps = $self->extract_prereqs($mymeta, $dist);
    } elsif (-e 'Makefile') {
        $self->chat("Finding PREREQ from Makefile ...\n");
        open my $mf, "Makefile";
        while (<$mf>) {
            if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/) {
                my @all;
                my @pairs = split ', ', $1;
                for (@pairs) {
                    my ($pkg, $v) = split '=>', $_;
                    push @all, [ $pkg, $v ];
                }
                my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all;
                my $prereq = $self->safe_eval("no strict; +{ $list }");
                push @deps, Dependency->from_versions($prereq) if $prereq;
                last;
            }
        }
    }

    return @deps;
}

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

    my @files;
    File::Find::find({
        wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
        no_chdir => 1,
    }, '.');

    my @deps;

    for my $file (@files) {
        open my $pod, "<", $file or next;
        my $in_contents;
        while (<$pod>) {
            if (/^=head\d\s+CONTENTS/) {
                $in_contents = 1;
            } elsif (/^=/) {
                $in_contents = 0;
            } elsif ($in_contents) {
                /^(\S+)\s*(\S+)?/
                    and push @deps, Dependency->new($1, $self->maybe_version($2));
            }
        }
    }

    return @deps;
}

sub maybe_version {
    my($self, $string) = @_;
    return $string && $string =~ /^\.?\d/ ? $string : undef;
}

sub extract_prereqs {
    my($self, $metadata, $dist) = @_;

    require CPAN::Meta;
    my $meta = CPAN::Meta->new($metadata, { lazy_validation => 1 });
    my @features = $self->configure_features($dist, $meta->features);

    return Dependency->from_prereqs($meta->effective_prereqs(\@features), $dist->{want_phases}, $self->{install_types});
}

sub cleanup_workdirs {
    my $self = shift;

    my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
    my @targets;

    opendir my $dh, "$self->{home}/work";
    while (my $e = readdir $dh) {
        next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID}
        my $time = $1;
        if ($time < $expire) {
            push @targets, "$self->{home}/work/$e";
        }
    }

    if (@targets) {
        if (@targets >= 64) {
            $self->diag("Expiring ", scalar(@targets), " work directories. This might take long...\n");
        } else {
            $self->chat("Expiring ", scalar(@targets), " work directories.\n");
        }
        File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits
    }
}

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

    my $new_node = [ $dist, [] ];

    my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
    push @{$curr_node->[1]}, $new_node;

    $self->{scandeps_current} = $new_node;

    return sub { $self->{scandeps_current} = $curr_node };
}

sub dump_scandeps {
    my $self = shift;

    if ($self->{format} eq 'tree') {
        $self->walk_down(sub {
            my($dist, $depth) = @_;
            if ($depth == 0) {
                print "$dist->{distvname}\n";
            } else {
                print " " x ($depth - 1);
                print "\\_ $dist->{distvname}\n";
            }
        }, 1);
    } elsif ($self->{format} =~ /^dists?$/) {
        $self->walk_down(sub {
            my($dist, $depth) = @_;
            print $self->format_dist($dist), "\n";
        }, 0);
    } elsif ($self->{format} eq 'json') {
        require JSON::PP;
        print JSON::PP::encode_json($self->{scandeps_tree});
    } elsif ($self->{format} eq 'yaml') {
        require YAML; # no fatpack
        print YAML::Dump($self->{scandeps_tree});
    } else {
        $self->diag("Unknown format: $self->{format}\n");
    }
}

sub walk_down {
    my($self, $cb, $pre) = @_;
    $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
}

sub _do_walk_down {
    my($self, $children, $cb, $depth, $pre) = @_;

    # DFS - $pre determines when we call the callback
    for my $node (@$children) {
        $cb->($node->[0], $depth) if $pre;
        $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
        $cb->($node->[0], $depth) unless $pre;
    }
}

sub DESTROY {
    my $self = shift;
    $self->{at_exit}->($self) if $self->{at_exit};
}

# Utils

sub shell_quote {
    my($self, @stuff) = @_;
    if (WIN32) {
        join ' ', map { /^${quote}.+${quote}$/ ? $_ : ($quote . $_ . $quote) } @stuff;
    } else {
        String::ShellQuote::shell_quote_best_effort(@stuff);
    }
}

sub which {
    my($self, $name) = @_;
    return $name if File::Spec->file_name_is_absolute($name) && -x $name;
    my $exe_ext = $Config{_exe};
    for my $dir (File::Spec->path) {
        my $fullpath = File::Spec->catfile($dir, $name);
        if (-x $fullpath || -x ($fullpath .= $exe_ext)) {
            if ($fullpath =~ /\s/) {
                $fullpath = $self->shell_quote($fullpath);
            }
            return $fullpath;
        }
    }
    return;
}

sub get {
    my($self, $uri) = @_;
    if ($uri =~ /^file:/) {
        $self->file_get($uri);
    } else {
        $self->{_backends}{get}->(@_);
    }
}

sub mirror {
    my($self, $uri, $local) = @_;
    if ($uri =~ /^file:/) {
        $self->file_mirror($uri, $local);
    } else {
        $self->{_backends}{mirror}->(@_);
    }
}

sub untar    { $_[0]->{_backends}{untar}->(@_) };
sub unzip    { $_[0]->{_backends}{unzip}->(@_) };

sub uri_to_file {
    my($self, $uri) = @_;

    # file:///path/to/file -> /path/to/file
    # file://C:/path       -> C:/path
    if ($uri =~ s!file:/+!!) {
        $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
    }

    return $uri;
}

sub file_get {
    my($self, $uri) = @_;
    my $file = $self->uri_to_file($uri);
    open my $fh, "<$file" or return;
    join '', <$fh>;
}

sub file_mirror {
    my($self, $uri, $path) = @_;
    my $file = $self->uri_to_file($uri);
    File::Copy::copy($file, $path);
}

sub init_tools {
    my $self = shift;

    return if $self->{initialized}++;

    if ($self->{make} = $self->which($Config{make})) {
        $self->chat("You have make $self->{make}\n");
    }

    # use --no-lwp if they have a broken LWP, to upgrade LWP
    if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
        $self->chat("You have LWP $LWP::VERSION\n");
        my $ua = sub {
            LWP::UserAgent->new(
                parse_head => 0,
                env_proxy => 1,
                agent => $self->agent,
                timeout => 30,
                @_,
            );
        };
        $self->{_backends}{get} = sub {
            my $self = shift;
            my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
            return unless $res->is_success;
            return $res->decoded_content;
        };
        $self->{_backends}{mirror} = sub {
            my $self = shift;
            my $res = $ua->()->mirror(@_);
            die $res->content if $res->code == 501;
            $res->code;
        };
    } elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
        $self->chat("You have $wget\n");
        my @common = (
            '--user-agent', $self->agent,
            '--retry-connrefused',
            ($self->{verbose} ? () : ('-q')),
        );
        $self->{_backends}{get} = sub {
            my($self, $uri) = @_;
            $self->safeexec( my $fh, $wget, $uri, @common, '-O', '-' ) or die "wget $uri: $!";
            local $/;
            <$fh>;
        };
        $self->{_backends}{mirror} = sub {
            my($self, $uri, $path) = @_;
            $self->safeexec( my $fh, $wget, $uri, @common, '-O', $path ) or die "wget $uri: $!";
            local $/;
            <$fh>;
        };
    } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
        $self->chat("You have $curl\n");
        my @common = (
            '--location',
            '--user-agent', $self->agent,
            ($self->{verbose} ? () : '-s'),
        );
        $self->{_backends}{get} = sub {
            my($self, $uri) = @_;
            $self->safeexec( my $fh, $curl, @common, $uri ) or die "curl $uri: $!";
            local $/;
            <$fh>;
        };
        $self->{_backends}{mirror} = sub {
            my($self, $uri, $path) = @_;
            $self->safeexec( my $fh, $curl, @common, $uri, '-#', '-o', $path ) or die "curl $uri: $!";
            local $/;
            <$fh>;
        };
    } else {
        require HTTP::Tiny;
        $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
        my %common = (
            agent => $self->agent,
        );
        $self->{_backends}{get} = sub {
            my $self = shift;
            my $res = HTTP::Tiny->new(%common)->get($_[0]);
            return unless $res->{success};
            return $res->{content};
        };
        $self->{_backends}{mirror} = sub {
            my $self = shift;
            my $res = HTTP::Tiny->new(%common)->mirror(@_);
            return $res->{status};
        };
    }

    my $tar = $self->which('tar');
    my $tar_ver;
    my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };

    if ($tar && !$maybe_bad_tar->()) {
        chomp $tar_ver;
        $self->chat("You have $tar: $tar_ver\n");
        $self->{_backends}{untar} = sub {
            my($self, $tarfile) = @_;

            my $xf = ($self->{verbose} ? 'v' : '')."xf";
            my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';

            my($root, @others) = `$tar ${ar}tf $tarfile`
                or return undef;

            FILE: {
                chomp $root;
                $root =~ s!^\./!!;
                $root =~ s{^(.+?)/.*$}{$1};

                if (!length($root)) {
                    # archive had ./ as the first entry, so try again
                    $root = shift(@others);
                    redo FILE if $root;
                }
            }

            system "$tar $ar$xf $tarfile";
            return $root if -d $root;

            $self->diag_fail("Bad archive: $tarfile");
            return undef;
        }
    } elsif (    $tar
             and my $gzip = $self->which('gzip')
             and my $bzip2 = $self->which('bzip2')) {
        $self->chat("You have $tar, $gzip and $bzip2\n");
        $self->{_backends}{untar} = sub {
            my($self, $tarfile) = @_;

            my $x  = "x" . ($self->{verbose} ? 'v' : '') . "f -";
            my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;

            my($root, @others) = `$ar -dc $tarfile | $tar tf -`
                or return undef;

            FILE: {
                chomp $root;
                $root =~ s!^\./!!;
                $root =~ s{^(.+?)/.*$}{$1};

                if (!length($root)) {
                    # archive had ./ as the first entry, so try again
                    $root = shift(@others);
                    redo FILE if $root;
                }
            }

            system "$ar -dc $tarfile | $tar $x";
            return $root if -d $root;

            $self->diag_fail("Bad archive: $tarfile");
            return undef;
        }
    } elsif (eval { require Archive::Tar }) { # uses too much memory!
        $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
        $self->{_backends}{untar} = sub {
            my $self = shift;
            my $t = Archive::Tar->new($_[0]);
            my($root, @others) = $t->list_files;
            FILE: {
                $root =~ s!^\./!!;
                $root =~ s{^(.+?)/.*$}{$1};

                if (!length($root)) {
                    # archive had ./ as the first entry, so try again
                    $root = shift(@others);
                    redo FILE if $root;
                }
            }
            $t->extract;
            return -d $root ? $root : undef;
        };
    } else {
        $self->{_backends}{untar} = sub {
            die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
        };
    }

    if (my $unzip = $self->which('unzip')) {
        $self->chat("You have $unzip\n");
        $self->{_backends}{unzip} = sub {
            my($self, $zipfile) = @_;

            my $opt = $self->{verbose} ? '' : '-q';
            my(undef, $root, @others) = `$unzip -t $zipfile`
                or return undef;

            chomp $root;
            $root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};

            system "$unzip $opt $zipfile";
            return $root if -d $root;

            $self->diag_fail("Bad archive: [$root] $zipfile");
            return undef;
        }
    } else {
        $self->{_backends}{unzip} = sub {
            eval { require Archive::Zip }
                or  die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
            my($self, $file) = @_;
            my $zip = Archive::Zip->new();
            my $status;
            $status = $zip->read($file);
            $self->diag_fail("Read of file[$file] failed")
                if $status != Archive::Zip::AZ_OK();
            my @members = $zip->members();
            for my $member ( @members ) {
                my $af = $member->fileName();
                next if ($af =~ m!^(/|\.\./)!);
                $status = $member->extractToFileNamed( $af );
                $self->diag_fail("Extracting of file[$af] from zipfile[$file failed")
                    if $status != Archive::Zip::AZ_OK();
            }

            my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
            $root &&= $root->fileName;
            return -d $root ? $root : undef;
        };
    }
}

sub safeexec {
    my $self = shift;
    my $rdr = $_[0] ||= Symbol::gensym();

    if (WIN32) {
        my $cmd = $self->shell_quote(@_[1..$#_]);
        return open( $rdr, "$cmd |" );
    }

    if ( my $pid = open( $rdr, '-|' ) ) {
        return $pid;
    }
    elsif ( defined $pid ) {
        exec( @_[ 1 .. $#_ ] );
        exit 1;
    }
    else {
        return;
    }
}

sub parse_meta {
    my($self, $file) = @_;
    return eval { Parse::CPAN::Meta->load_file($file) };
}

sub parse_meta_string {
    my($self, $yaml) = @_;
    return eval { Parse::CPAN::Meta->load_yaml_string($yaml) };
}

1;