App-ShellCompleter-cpanm

 view release on metacpan or  search on metacpan

devdata/Menlo-CLI-Compat.v1.9022.pm.txt  view on Meta::CPAN

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

    return "$homedir/.cpanm";
}

sub new {
    my $class = shift;

    my $self = bless {
        name => "Menlo",
        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,
        cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
        perl => $^X,
        argv => [],
        local_lib => undef,
        self_contained => undef,
        exclude_vendor => 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,
        static_install => 1,
        auto_cleanup => 7, # days
        pod2man => 1,
        installed_dists => 0,
        install_types => ['requires'],
        with_develop => 0,
        with_configure => 0,
        showdeps => 0,
        scandeps => 0,
        scandeps_tree => [],
        format   => 'tree',
        save_dists => undef,
        skip_configure => 0,
        verify => 0,
        report_perl_version => !$class->maybe_ci,
        build_args => {},
        features => {},
        pure_perl => 0,
        cpanfile_path => 'cpanfile',
        @_,
    }, $class;

    $self;
}

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

sub maybe_ci {
    my $class = shift;
    grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING );
}

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, grep length, 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' => \$self->{verbose},
        'verify!'   => \$self->{verify},
        'q|quiet!'  => \$self->{quiet},
        'h|help'    => sub { $self->{action} = 'show_help' },
        'V|version' => sub { $self->{action} = 'show_version' },
        'perl=s'    => sub {
            $self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1);
            $self->{perl} = $_[1];
        },
        '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},
        'exclude-vendor!' => \$self->{exclude_vendor},
        'mirror=s@' => $self->{mirrors},
        'mirror-only!' => \$self->{mirror_only},
        'mirror-index=s' => sub { $self->{mirror_index} = $self->maybe_abs($_[1]) },
        'M|from=s' => sub {
            $self->{mirrors}     = [$_[1]];
            $self->{mirror_only} = 1;
        },
        'cpanmetadb=s'    => \$self->{cpanmetadb},
        '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 },
        'U|uninstall'  => sub { $self->{cmd} = 'uninstall' },
        'self-upgrade' => sub { $self->{action} = 'self_upgrade' },
        '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},
        'static-install!' => \$self->{static_install},
        '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-configure' => \$self->{with_configure},
        'without-configure' => sub { $self->{with_configure} = 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 },
        'pp|pureperl!' => \$self->{pure_perl},
        "cpanfile=s" => \$self->{cpanfile_path},
        $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 {
    my $self = shift;
    my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
    if ($0 eq '-') {
        # run from curl, that's fine
        return;
    } elsif ($0 !~ /^$install_base/) {
        if ($0 =~ m!perlbrew/bin!) {
            die <<DIE;
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

DIE
        } else {
            die <<DIE;
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.
DIE
        }
    }
}

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

sub setup_verify {
    my $self = shift;

    my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
    $self->{cpansign} = 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 run {
    my $self = shift;

    my $code;
    eval {
        $code = ($self->_doit == 0);
    }; if (my $e = $@) {
        warn $e;
        $code = 1;
    }

    $self->{status} = $code;
}

sub status {
    $_[0]->{status};
}

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

    return $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);
        if ($self->{cmd} eq 'uninstall') {
            $self->uninstall_module($module)
              or push @fail, $module;
        } else {
            $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";

devdata/Menlo-CLI-Compat.v1.9022.pm.txt  view on Meta::CPAN

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

    for my $uri (@{$dist->{uris}}) {
        $self->mask_output( 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->mask_output( diag_fail => "Download $uri failed. Retrying ... ");
        }

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

        unless ($file) {
            $self->mask_output( 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");
        return 1;
    }

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

    (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
    my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
    $self->mask_output( 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->sha_for(256, $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 sha_for {
    my($self, $alg, $file) = @_;

    require Digest::SHA; # no fatpack

    open my $fh, "<", $file or die "$file: $!";
    my $dg = Digest::SHA->new($alg);
    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 = `@{[ qs $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 verification for $dist->{filename} failed\n");
        return;
    }
}

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

    if ($dep && $dep->url) {
        if ($dep->url =~ m!authors/id/(.*)!) {
            return $self->cpan_dist($1, $dep->url);
        } else {
            return { uris => [ $dep->url ] };
        }
    }

    if ($dep && $dep->dist) {
        return $self->cpan_dist($dep->dist, undef, $dep->mirror);
    }

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

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

devdata/Menlo-CLI-Compat.v1.9022.pm.txt  view on Meta::CPAN

            push @install, $dep;
            $seen{$dep->module} = 1;
        }
    }

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

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

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

    if ($self->{scandeps}) {
        return 1; # Don't check if dependencies are installed, since with --scandeps they aren't
    }
    my @not_ok = $self->unsatisfied_deps(@deps);
    if (@not_ok) {
        return 0, \@not_ok;
    } else {
        return 1;
    }
}

sub unsatisfied_deps {
    my($self, @deps) = @_;

    require CPAN::Meta::Check;
    require CPAN::Meta::Requirements;

    my $reqs = CPAN::Meta::Requirements->new;
    for my $dep (grep $_->is_requirement, @deps) {
        $reqs->add_string_requirement($dep->module => $dep->requires_version || '0');
    }

    my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc});
    grep defined, values %$ret;
}

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

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

    return 1;
}

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

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

    require CPAN::Meta;

    my($meta_file) = grep -f, qw(META.json META.yml);
    if ($meta_file) {
        $self->chat("Checking configure dependencies from $meta_file\n");
        $dist->{cpanmeta} = eval { CPAN::Meta->load_file($meta_file) };
    } elsif ($dist->{dist} && $dist->{version}) {
        $self->chat("META.yml/json not found. Creating skeleton for it.\n");
        $dist->{cpanmeta} = CPAN::Meta->new({ name => $dist->{dist}, version => $dist->{version} });
    }

    $dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {};

    if ($self->opts_in_static_install($dist->{cpanmeta})) {
        $dist->{static_install} = 1;
    }

    my @config_deps;

    if ($dist->{cpanmeta}) {
        push @config_deps, Menlo::Dependency->from_prereqs(
            $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
        );
    }

    if (-e 'Build.PL' && !@config_deps) {
        push @config_deps, Menlo::Dependency->from_versions(
            { 'Module::Build' => '0.38' }, 'configure',
        );
    }

    $self->merge_with_cpanfile($dist, \@config_deps);

    $self->upgrade_toolchain(\@config_deps);

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

    unless ($self->skip_configure($dist, $depth)) {
        $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");

    if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') {
        $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, ".");
    }

    # install direct 'test' dependencies for --installdeps, even with --notest
    # TODO: remove build dependencies for static install
    my $deps_only = $self->deps_only($depth);
    $dist->{want_phases} = $self->{notest} && !$self->deps_only($depth)
                         ? [qw( build runtime )] : [qw( build test runtime )];

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

devdata/Menlo-CLI-Compat.v1.9022.pm.txt  view on Meta::CPAN

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

    my $source_mtime = (stat $file)[9];

    # Don't mirror a file that's already there (like the index)
    return 1 if -e $path && (stat $path)[9] >= $source_mtime;

    File::Copy::copy($file, $path);

    utime $source_mtime, $source_mtime, $path;
}

sub configure_http {
    my $self = shift;

    require HTTP::Tinyish;

    my @try = qw(HTTPTiny);
    unshift @try, 'Wget' if $self->{try_wget};
    unshift @try, 'Curl' if $self->{try_curl};
    unshift @try, 'LWP'  if $self->{try_lwp};

    my @protocol = ('http');
    push @protocol, 'https'
      if grep /^https:/, @{$self->{mirrors}};

    my $backend;
    for my $try (map "HTTP::Tinyish::$_", @try) {
        if (my $meta = HTTP::Tinyish->configure_backend($try)) {
            if ((grep $try->supports($_), @protocol) == @protocol) {
                for my $tool (sort keys %$meta){
                    (my $desc = $meta->{$tool}) =~ s/^(.*?)\n.*/$1/s;
                    $self->chat("You have $tool: $desc\n");
                }
                $backend = $try;
                last;
            }
        }
    }

    $backend->new(agent => "Menlo/$Menlo::VERSION", verify_SSL => 1);
}

sub init_tools {
    my $self = shift;

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

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

    $self->{http} = $self->configure_http;

    my $tar = which('tar');
    my $tar_ver;
    my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `@{[ qs $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) = `@{[ qs $tar ]} ${ar}tf @{[ qs $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;
                }
            }

            $self->run_command([ $tar, $ar.$xf, $tarfile ]);
            return $root if -d $root;

            $self->diag_fail("Bad archive: $tarfile");
            return undef;
        }
    } elsif (    $tar
             and my $gzip = which('gzip')
             and my $bzip2 = 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) = `@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $tar ]} tf -`
                or return undef;