#!perl
my $quote = $^O eq 'MSWin32' ? q/"/ : q/'/;

unless (caller) {
    my $app = App::cpanminus::script->new;
    $app->parse_options(@ARGV);
    $app->doit;
}

package App::cpanminus::script;
use strict;
use Config;
use Cwd ();
use File::Basename ();
use File::Spec ();
use File::Copy ();
use Getopt::Long ();

use constant WIN32 => $^O eq 'MSWin32';
use constant PLUGIN_API_VERSION => 0.1;

our $VERSION;BEGIN{
$VERSION = "0.99_02";
}
$VERSION = eval $VERSION;

sub new {
    my $class = shift;

    bless {
        home => File::Spec->catfile($ENV{HOME}, ".cpanm"),
        cmd  => 'install',
        seen => {},
        notest => undef,
        installdeps => undef,
        force => undef,
        sudo => undef,
        make  => undef,
        verbose => undef,
        interactive => undef,
        log => undef,
        mirrors => [],
        perl => $^X,
        argv => undef,
        hooks => {},
        plugins => [],
        configure_timeout => 60,
        build_timeout => 60 * 10,
        test_timeout  => 60 * 10,
        @_,
    }, $class;
}

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

sub parse_options {
    my $self = shift;
    local @ARGV = @_;

    Getopt::Long::Configure("bundling");
    Getopt::Long::GetOptions(
        'f|force'  => \$self->{force},
        'n|notest' => \$self->{notest},
        'S|sudo'   => \$self->{sudo},
        'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
        'q|quiet'   => sub {},
        'h|help'    => sub { $self->{action} = 'help' },
        'V|version' => sub { $self->{action} = 'version' },
        'perl'      => \$self->{perl},
        'recent'    => sub { $self->{action} = 'show_recent' },
        'list-plugins' => sub { $self->{action} = 'list_plugins' },
        'installdeps' => \$self->{installdeps},
        'interactive' => \$self->{interactive},
        'i|install' => sub { $self->{cmd} = 'install' },
        'look'      => sub { $self->{cmd} = 'look' },
        'info'      => sub { $self->{cmd} = 'info' },
        'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{argv} = [ 'App::cpanminus' ] },
        'disable-plugins' => \$self->{disable_plugins},
    );

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

sub doit {
    my $self = shift;

    $self->setup_home;
    $self->load_plugins;
    $self->sanity_check;

    $self->{make} = Util::which($Config{make});

    Util::init_tools($self);

    $self->configure_mirrors;

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

    $self->help(1) unless @{$self->{argv}};

    for my $module (@{$self->{argv}}) {
        $self->install_module($module);
    }

    $self->run_hooks(finalize => {});
}

sub guard(&) {
    my $cb = shift;
    bless $cb, 'Util::Guard';
}

sub setup_home {
    my $self = shift;

    $self->{home} = $self->env('HOME') if $self->env('HOME');
    mkdir $self->{home}, 0777 unless -e $self->{home};

    for my $dir (qw( plugins work )) {
        my $sub = File::Spec->catfile($self->{home}, $dir);
        unless (-e $sub) {
            mkdir $sub, 0777 or die "$dir: $!";
        }
    }

    $self->{base} = File::Spec->catfile($self->{home}, "work", time . ".$$");
    mkdir $self->{base}, 0777 or die "$self->{base}: $!";

    my $link = File::Spec->catfile($self->{home}, 'latest-build');
    eval { unlink $link; symlink $self->{base}, $link };

    $self->{log} = File::Spec->catfile($self->{home}, "build.log");
    $self->{at_exit} = guard { File::Copy::copy($self->{log}, File::Spec->catfile($self->{base}, 'build.log')) };

    open my $out, ">$self->{log}" or die "$self->{log}: $!";
    print $out "cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n";
    print $out "Work directory is $self->{base}\n";

    $self->{plugin_dir} = File::Spec->catfile($self->{home}, "plugins");
}

sub register_core_hooks {
    my $self = shift;

    $self->hook('core', search_module => sub {
        my $args = shift;
        push @{$args->{uris}}, sub {
            $self->chat("Searching $args->{module} on search.cpan.org ...\n");
            my $uri  = "http://search.cpan.org/perldoc?$args->{module}";
            my $html = Util::get($uri);
            $html =~ m!Download:.*<a href="/CPAN/authors/id/(.*?)">.*?</a>!
                and return $self->cpan_uri($1);
            $self->diag("! Finding $args->{module} on search.cpan.org failed.\n");
            return;
        };
    });

    $self->hook('core', show_recent => sub {
        my $args = shift;

        $self->chat("Fetching recent feed from search.cpan.org ...\n");
        my $feed = Util::get("http://search.cpan.org/uploads.rdf");

        my @dists;
        while ($feed =~ m!<link>http://search\.cpan\.org/~([a-z_\-0-9]+)/(.*?)/</link>!g) {
            my($pause_id, $dist) = (uc $1, $2);
            push @dists, substr($pause_id, 0, 1) . "/" . substr($pause_id, 0, 2) . "/" . $pause_id . "/$dist.tar.gz";
            last if @dists >= 50;
        }

        return \@dists;
    });
}

sub load_plugins {
    my $self = shift;

    $self->_load_plugins;
    $self->register_core_hooks;

    for my $hook (keys %{$self->{hooks}}) {
        $self->{hooks}->{$hook} = [ sort { $a->[0] <=> $b->[0] } @{$self->{hooks}->{$hook}} ];
    }

    $self->run_hooks(init => {});
}

sub _load_plugins {
    my $self = shift;
    return if $self->{disable_plugins};
    return unless $self->{plugin_dir} && -e $self->{plugin_dir};

    opendir my $dh, $self->{plugin_dir} or return;
    my @plugins;
    while (my $e = readdir $dh) {
        my $f = File::Spec->catfile($self->{plugin_dir}, $e);
        next unless -f $f && $e =~ /^[A-Za-z0-9_]+$/ && $e ne 'README';
        push @plugins, [ $f, $e ];
    }

    for my $plugin (sort { $a->[1] <=> $b->[1] } @plugins) {
        $self->load_plugin(@$plugin);
    }
}

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

    # TODO remove this once plugin API is official
    unless ($self->env('DEV')) {
        $self->chat("! Found plugin $file but PERL_CPANM_DEV is not set. Skipping.\n");
        return;
    }

    $self->chat("Loading plugin $file\n");

    my $plugin = { name => $name, file => $file };
    my @attr   = qw( name description author version api_version synopsis );
    my $dsl    = join "\n", map "sub $_ { \$plugin->{$_} = shift }", @attr;

    (my $package = $file) =~ s/[^a-zA-Z0-9_]/_/g;
    my $code = do { open my $io, "<$file"; local $/; <$io> };

    my @hooks;
    eval "package App::cpanplus::plugin::$package;\n".
        "use strict;\n$dsl\n" .
        "sub hook { push \@hooks, [\@_] };\n$code";

    if ($plugin->{api_version} < PLUGIN_API_VERSION) {
        $self->diag("! $plugin->{name} plugin API version is outdated ($plugin->{api_version}) and needs an update.\n");
        return;
    }

    for my $hook (@hooks) {
        $self->hook($plugin->{name}, @$hook);
    }

    $self->diag("! Loading plugin $file faield: $@") if $@;

    push @{$self->{plugins}}, $plugin;
}

sub hook {
    my $cb = pop;
    my($self, $name, $hook, $order) = @_;
    $order = 50 unless defined $order;
    push @{$self->{hooks}->{$hook}}, [ $order, $cb, $name ];
}

sub run_hook {
    my($self, $hook, $args) = @_;
    $self->run_hooks($hook, $args, 1);
}

sub run_hooks {
    my($self, $hook, $args, $first) = @_;

    my $res;
    for my $plugin (@{$self->{hooks}->{$hook} || []}) {
        $res = eval { $plugin->[1]->({ %$args, app => $self }) };
        $self->chat("Running hook '$plugin->[2]' error: $@") if $@;
        last if $res && $first;
    }

    return $res;
}

sub version {
    print "cpanm (App::cpanminus) version $VERSION\n";
    return 1;
}

sub help {
    my $self = shift;
    my $how  = $_[0] ? sub { die @_ } : sub { print @_ };
    $how->(<<USAGE);
Usage: cpanm [options] Module [...]

Options:
  -v,--verbose       Turns on chatty output
  --interactive      Turns on interactive configure (required for Task:: modules)
  -f,--force         force install
  -n,--notest        Do not run unit tests
  -S,--sudo          sudo to run install commands
  --installdeps      Only install dependencies
  --disable-plugins  Disable plugin loading

Commands:
  --self-upgrade     upgrades itself
  --look             Download the tarball and open the directory with your shell
  --info             Displays distribution info on CPAN
  --recent           Show recently updated modules

Examples:

  # install CGI
  cpanm CGI

  # specify the version
  cpanm MIYAGAWA/Plack-0.99_05.tar.gz

  # install from an URL
  cpanm http://backpan.perl.org/authors/id/L/LD/LDS/CGI.pm-3.20.tar.gz

  # install Task:: modlues (You need --interactive or -v to answer questions)
  cpanm --interactive Task::Kensho

  # install from local directory, just like `cpan .`
  cpanm .

  # install all the dependencies for the current directory
  cpanm --installdeps .

  # install from a local file
  cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz

USAGE

    return 1;
}

sub sanity_check {
    my $self = shift;
    unless ($ENV{PERL_MM_OPT} or $ENV{MODULEBUILDRC} or -w $Config{installsitelib} or $self->{sudo}) {
        die "Can't write to $Config{installsitelib}: Run me as root or with --sudo option.\n";
    }
}

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

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) = @_;
    unless ($self->{verbose}) {
        $cmd .= " >> " . Util::quote($self->{log}) . " 2>&1";
    }
    !system $cmd;
}

sub run_exec {
    my($self, $cmd) = @_;
    unless ($self->{verbose}) {
        $cmd .= " >> " . Util::quote($self->{log}) . " 2>&1";
    }
    exec $cmd;
    return;
}

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

    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("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 configure {
    my($self, $cmd) = @_;

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

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

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

sub build {
    my($self, $cmd) = @_;
    $self->run_timeout($cmd, $self->{build_timeout});
}

sub test {
    my($self, $cmd) = @_;
    return 1 if $self->{notest};
    return $self->run_timeout($cmd,  $self->{test_timeout}) || $self->{force};
}

sub install {
    my($self, $cmd) = @_;
    $cmd = "sudo $cmd" if $self->{sudo};
    $self->run($cmd);
}

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

sub configure_mirrors {
    my $self = shift;

    my @mirrors;
    $self->run_hook(configure_mirrors => { mirrors => \@mirrors });

    @mirrors = ('http://search.cpan.org/CPAN') unless @mirrors;
    $self->{mirrors} = \@mirrors;
}

sub show_recent {
    my $self = shift;

    my $dists = $self->run_hook(show_recent => {});
    for my $dist (@$dists) {
        print $dist, "\n";
    }

    return 1;
}

sub list_plugins {
    my $self = shift;

    for my $plugin (@{$self->{plugins}}) {
        print "$plugin->{name} - $plugin->{description}\n";
    }

    return 1;
}

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

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

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

    my $dir = $self->fetch_module($module);

    return if $self->{cmd} eq 'info';

    unless ($dir) {
        $self->diag("! Couldn't find module or a distribution $module\n");
        return;
    }

    if ($self->{seen}{$dir}++) {
        $self->diag("Already built the distribution $dir. Skipping.\n");
        return;
    }

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

    if ($self->{cmd} eq 'look') {
        $self->diag("Entering $dir with $ENV{SHELL}\n");
        system $ENV{SHELL};
    } else {
        $self->build_stuff($module, $dir, $is_dep)
    }
}

sub generator_cb {
    my($self, $ref) = @_;

    $ref = [ $ref ] unless ref $ref eq 'ARRAY';

    my @stack;
    return sub {
        if (@stack) {
            return shift @stack;
        }

        return -1 unless @$ref;
        my $curr = (shift @$ref)->();
        if (ref $curr eq 'ARRAY') {
            @stack = @$curr;
            return shift @stack;
        } else {
            return $curr;
        }
    };
}

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

    my($uris, $local_dir) = $self->locate_dist($module);

    return $local_dir if $local_dir;
    return unless $uris;

    my $iter = $self->generator_cb($uris);

    while (1) {
        my $uri = $iter->();
        last if $uri == -1;
        next unless $uri;

        # Yikes this is dirty
        if ($self->{cmd} eq 'info') {
            $uri =~ s!.*authors/id/!!;
            print $uri, "\n";
            return;
        }

        if ($uri =~ m{/perl-5}){
            $self->diag("skip $uri\n");
            next;
        }

        $self->chdir($self->{base});
        $self->diag("Fetching $uri ... ");

        my $name = File::Basename::basename $uri;

        my $cancelled;
        my $fetch = sub {
            eval {
                local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
                Util::mirror($uri, $name);
                return $name if -e $name;
                return;
            };
        };

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

        if ($cancelled) {
            $self->diag("\n! Download cancelled.\n");
            return;
        }

        unless ($file) {
            $self->diag("FAIL\n! Failed to download $uri\n");
            next;
        }

        $self->diag("OK\n");
        $self->chat("Unpacking $file\n");

        my $dir = Util::untar($file);
        unless ($dir) {
            $self->diag("! Failed to unpack $name: no directory\n");
            next;
        }

        return $dir;
    }
}

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

    if (my $located = $self->run_hook(locate_dist => { module => $module })) {
        return ref $located eq 'ARRAY' ? @$located :
               ref $located eq 'CODE'  ? $located  : sub { $located };
    }

    # URL
    return sub { $module } if $module =~ /^(ftp|https?|file):/;

    # Directory
    return undef, Cwd::abs_path($module) if -e $module && -d _;

    # File
    return sub { "file://" . Cwd::abs_path($module) } if -f $module;

    # cpan URI
    $module =~ s!^cpan:///distfile/!!;

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

    # CPAN tarball
    return sub { $self->cpan_uri($module) } if $module =~ m!^[A-Z]/[A-Z]{2}/!;

    # Module name -- search.cpan.org
    return $self->search_module($module);
}

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

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

    return wantarray ? @urls : $urls[int(rand($#urls))];
}

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

    my @cbs;
    $self->run_hooks(search_module => { module => $module, uris => \@cbs });

    return \@cbs;
}

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

    my @install;
    while (my($mod, $ver) = each %deps) {
        next if $mod eq 'perl' or $mod eq 'Config';
        $self->chat("Checking if you have $mod $ver ... ");
        $ver = '' if $ver == 0;
        my $test = `$self->{perl} -e ${quote}eval q{use $mod $ver (); print q{OK:}, $mod\::->VERSION};print \$\@ if \$\@${quote}`;
        if ($test =~ s/^\s*OK://) {
            $self->chat("Yes ($test)\n");
        } elsif ($test =~ /^Can't locate|required--this is only version (\S+)/) {
            $self->chat("No ", ($1 ? "($1 < $ver)\n" : "\n"));
            push @install, $mod;
        } else {
            $self->chat("Unknown ($test)\n");
        }
    }

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

    for my $mod (@install) {
        $self->install_module($mod, 1);
    }

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

sub build_stuff {
    my($self, $module, $dir, $is_dep) = @_;

    my $fail;
    $self->run_hooks(verify_dist => { module => $module, dir => $dir, fail => \$fail });

    if ($fail && !$self->{force}) {
        $self->diag("! Verifying the module $module failed. Skipping. (use --force to install)\n");
        return;
    }

    if (-e 'META.yml') {
        $self->chat("Checking configure dependencies from META.yml ...\n");
        my $meta = Util::parse_meta('META.yml');
        my %deps = %{$meta->{configure_requires} || {}};

        $self->install_deps($dir, %deps);
    }

    my($use_module_build, $configured);
    if (-e 'Makefile.PL') {
        local $ENV{X_MYMETA} = 'YAML';
        $self->configure("$self->{perl} Makefile.PL");
        $configured = 1;
    }

    if ((!$self->{make} or !$configured) and -e 'Build.PL') {
        $self->configure("$self->{perl} Build.PL");
        $use_module_build = 1;
        $configured = 1;
    }

    my %deps;
    my $meta = {};
    my($metayml) = grep -e $_, qw( MYMETA.yml META.yml );
    if ($metayml) {
        $self->chat("Checking dependencies from $metayml ...\n");
        $meta = Util::parse_meta($metayml);
        %deps = (%{$meta->{requires} || {}});
        unless ($self->{notest}) {
            %deps = (%deps, %{$meta->{build_requires} || {}}, %{$meta->{test_requires} || {}});
        }
    }

    if (-e 'Makefile') {
        $self->chat("Finding PREREQ from Makefile ...\n");
        open my $mf, "Makefile";
        while (<$mf>) {
            if (/^\#\s+PREREQ_PM => ({.*?})/) {
                no strict; # WTF bareword keys
                my $prereq = eval "+$1";
                %deps = (%deps, %$prereq) if $prereq;
                last;
            }
        }
    }

    $self->run_hooks(find_deps => { deps => \%deps, module => $module, meta => $meta });

    $self->install_deps($dir, %deps);

    if ($self->{installdeps} && !$is_dep) {
        $self->diag("<== Installed dependencies for $module. Finishing.\n");
        return 1;
    }

    unless ($configured) {
        $self->diag("! Oops, you don't have make or the dist didn't have Makefile.PL.\n");
        $self->diag("! Trying to build a stub Build file for you. Hope this works!\n");
        {
            open my $mb, ">Build.PL";
            print $mb "require Module::Build;Module::Build->new(module_name => '$module',";
            print $mb "dist_name => '$meta->{name}', dist_version => '$meta->{version}'" if $meta;
            print $mb ")->create_build_script;";
        }

        $self->configure("$self->{perl} Build.PL");
        $use_module_build = 1;
    }

    $self->diag("Building ", ($self->{notest} ? "" : "and testing "), "$dir for $module ... ");

    my $installed;
    if ($use_module_build && -e 'Build' && -f _) {
        $self->build("$self->{perl} ./Build") &&
        $self->test("$self->{perl} ./Build test") &&
        $self->install("$self->{perl} ./Build install") &&
        $installed++;
    } elsif ($self->{make} && -e 'Makefile') {
        $self->build("$self->{make}") &&
        $self->test("$self->{make} test") &&
        $self->install("$self->{make} install") &&
        $installed++;
    } else {
        $self->diag("FAIL\n! Sorry, I don't know how to build $dir\n");
        return;
    }

    if ($installed) {
        $self->diag("OK\n$module installed successfully.\n");
        $self->run_hooks(install_success => { module => $module, build_dir => $dir, meta => $meta });
        return 1;
    } else {
        $self->diag("FAIL\n! Installing $module failed. See $self->{log} for details.\n");
        $self->run_hooks(build_failure => { module => $module, build_dir => $dir, meta => $meta });
        return;
    }
}

package Util;

use Config;
sub get($);
sub mirror($$);
sub redirect;
sub untar;

sub quote {
    my $stuff = shift;
    $quote . $stuff . $quote;
}

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

sub file_mirror {
    my($uri, $path) = @_;
    File::Copy::copy($uri, $path);
}

sub init_tools {
    my $app = shift;

    # use PERL_CPANM_NO_LWP=1 if they have a broken LWP, to upgrade LWP
    if (!$app->env('NO_LWP') && eval { require LWP::Simple }) {
        *get = sub ($) {
            my $ua = LWP::UserAgent->new(parse_head => 0, env_proxy => 1);
            $ua->request(HTTP::Request->new(GET => $_[0]))->decoded_content;
        },
        *mirror = \&LWP::Simple::mirror;
        *redirect = sub {
            my $ua = LWP::UserAgent->new(parse_head => 0, max_redirect => 1, env_proxy => 1);
            my $res = $ua->simple_request(HTTP::Request->new(GET => $_[0]));
            return $res->header('Location') if $res->is_redirect;
            return;
        };
    } elsif (my $wget = which 'wget') {
        *get = sub ($) {
            my $uri = shift;
            my $q = $app->{verbose} ? '' : '-q';
            open my $fh, "$wget $uri $q -O - |" or die "wget $uri: $!";
            local $/;
            <$fh>;
        };
        *mirror = sub ($$) {
            my($uri, $path) = @_;
            return file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
            my $q = $app->{verbose} ? '' : '-q';
            system "$wget $uri $q -O $path";
        };
        *redirect = sub {
            my $uri = shift;
            my $out = `$wget --max-redirect=0 $uri 2>&1`;
            if ($out =~ /^Location: (\S+)/m) {
                return $1;
            }
            return;
        };
    }
    # TODO curl

    if (my $tar = which 'tar'){
        *untar = sub {
            my($tarfile) = @_;

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

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

            chomp $root;
            $root =~ s{^(.+)/[^/]*$}{$1};

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

            $app->diag("Bad archive: $tarfile\n");
            return undef;
        }
    } elsif (eval { require Archive::Tar }) { # uses too much memory!
        *untar = sub {
            my $t = Archive::Tar->new($_[0]);
            my $root = ($t->list_files)[0];
            $t->extract;
            return -d $root ? $root : undef;
        };
    }
}

sub parse_meta {
    my $file = shift;
    return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || {};
}

package Util::Guard;
sub DESTROY { $_[0]->() }

### Inline stripped Parse::CPAN::Meta
# Copyright: Adam Kennedy
package Parse::CPAN::Meta;
use Carp 'croak';
# Printable characters for escapes
my %UNESCAPES = (
	z => "\x00", a => "\x07", t    => "\x09",
	n => "\x0a", v => "\x0b", f    => "\x0c",
	r => "\x0d", e => "\x1b", '\\' => '\\',
);
# Create an object from a file
sub LoadFile ($) {
	# Check the file
	my $file = shift;
	croak('You did not specify a file name')            unless $file;
	croak( "File '$file' does not exist" )              unless -e $file;
	croak( "'$file' is a directory, not a file" )       unless -f _;
	croak( "Insufficient permissions to read '$file'" ) unless -r _;

	# Slurp in the file
	local $/ = undef;
	local *CFG;
	unless ( open( CFG, $file ) ) {
		croak("Failed to open file '$file': $!");
	}
	my $yaml = <CFG>;
	unless ( close(CFG) ) {
		croak("Failed to close file '$file': $!");
	}

	# Hand off to the actual parser
	Load( $yaml );
}

# Parse a document from a string.
# Doing checks on $_[0] prevents us having to do a string copy.
sub Load ($) {
	my $string = $_[0];
	unless ( defined $string ) {
		croak("Did not provide a string to load");
	}

	# Byte order marks
	if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
		croak("Stream has a non UTF-8 Unicode Byte Order Mark");
	} else {
		# Strip UTF-8 bom if found, we'll just ignore it
		$string =~ s/^\357\273\277//;
	}

	# Check for some special cases
	return () unless length $string;
	unless ( $string =~ /[\012\015]+\z/ ) {
		croak("Stream does not end with newline character");
	}

	# Split the file into lines
	my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
	            split /(?:\015{1,2}\012|\015|\012)/, $string;

	# Strip the initial YAML header
	@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;

	# A nibbling parser
	my @documents = ();
	while ( @lines ) {
		# Do we have a document header?
		if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
			# Handle scalar documents
			shift @lines;
			if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
				push @documents, _scalar( "$1", [ undef ], \@lines );
				next;
			}
		}

		if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
			# A naked document
			push @documents, undef;
			while ( @lines and $lines[0] !~ /^---/ ) {
				shift @lines;
			}

		} elsif ( $lines[0] =~ /^\s*\-/ ) {
			# An array at the root
			my $document = [ ];
			push @documents, $document;
			_array( $document, [ 0 ], \@lines );

		} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
			# A hash at the root
			my $document = { };
			push @documents, $document;
			_hash( $document, [ length($1) ], \@lines );

		} else {
			croak("Parse::CPAN::Meta failed to classify line '$lines[0]'");
		}
	}

	if ( wantarray ) {
		return @documents;
	} else {
		return $documents[-1];
	}
}

# Deparse a scalar string to the actual scalar
sub _scalar ($$$) {
	my ($string, $indent, $lines) = @_;

	# Trim trailing whitespace
	$string =~ s/\s*\z//;

	# Explitic null/undef
	return undef if $string eq '~';

	# Quotes
	if ( $string =~ /^\'(.*?)\'\z/ ) {
		return '' unless defined $1;
		$string = $1;
		$string =~ s/\'\'/\'/g;
		return $string;
	}
	if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
		# Reusing the variable is a little ugly,
		# but avoids a new variable and a string copy.
		$string = $1;
		$string =~ s/\\"/"/g;
		$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
		return $string;
	}

	# Special cases
	if ( $string =~ /^[\'\"!&]/ ) {
		croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
	}
	return {} if $string eq '{}';
	return [] if $string eq '[]';

	# Regular unquoted string
	return $string unless $string =~ /^[>|]/;

	# Error
	croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines;

	# Check the indent depth
	$lines->[0]   =~ /^(\s*)/;
	$indent->[-1] = length("$1");
	if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
		croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
	}

	# Pull the lines
	my @multiline = ();
	while ( @$lines ) {
		$lines->[0] =~ /^(\s*)/;
		last unless length($1) >= $indent->[-1];
		push @multiline, substr(shift(@$lines), length($1));
	}

	my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
	my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
	return join( $j, @multiline ) . $t;
}

# Parse an array
sub _array ($$$) {
	my ($array, $indent, $lines) = @_;

	while ( @$lines ) {
		# Check for a new document
		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
			while ( @$lines and $lines->[0] !~ /^---/ ) {
				shift @$lines;
			}
			return 1;
		}

		# Check the indent level
		$lines->[0] =~ /^(\s*)/;
		if ( length($1) < $indent->[-1] ) {
			return 1;
		} elsif ( length($1) > $indent->[-1] ) {
			croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
		}

		if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
			# Inline nested hash
			my $indent2 = length("$1");
			$lines->[0] =~ s/-/ /;
			push @$array, { };
			_hash( $array->[-1], [ @$indent, $indent2 ], $lines );

		} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
			# Array entry with a value
			shift @$lines;
			push @$array, _scalar( "$2", [ @$indent, undef ], $lines );

		} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
			shift @$lines;
			unless ( @$lines ) {
				push @$array, undef;
				return 1;
			}
			if ( $lines->[0] =~ /^(\s*)\-/ ) {
				my $indent2 = length("$1");
				if ( $indent->[-1] == $indent2 ) {
					# Null array entry
					push @$array, undef;
				} else {
					# Naked indenter
					push @$array, [ ];
					_array( $array->[-1], [ @$indent, $indent2 ], $lines );
				}

			} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
				push @$array, { };
				_hash( $array->[-1], [ @$indent, length("$1") ], $lines );

			} else {
				croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
			}

		} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
			# This is probably a structure like the following...
			# ---
			# foo:
			# - list
			# bar: value
			#
			# ... so lets return and let the hash parser handle it
			return 1;

		} else {
			croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
		}
	}

	return 1;
}

# Parse an array
sub _hash ($$$) {
	my ($hash, $indent, $lines) = @_;

	while ( @$lines ) {
		# Check for a new document
		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
			while ( @$lines and $lines->[0] !~ /^---/ ) {
				shift @$lines;
			}
			return 1;
		}

		# Check the indent level
		$lines->[0] =~ /^(\s*)/;
		if ( length($1) < $indent->[-1] ) {
			return 1;
		} elsif ( length($1) > $indent->[-1] ) {
			croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
		}

		# Get the key
		unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
			if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
				croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
			}
			croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
		}
		my $key = $1;

		# Do we have a value?
		if ( length $lines->[0] ) {
			# Yes
			$hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
		} else {
			# An indent
			shift @$lines;
			unless ( @$lines ) {
				$hash->{$key} = undef;
				return 1;
			}
			if ( $lines->[0] =~ /^(\s*)-/ ) {
				$hash->{$key} = [];
				_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
			} elsif ( $lines->[0] =~ /^(\s*)./ ) {
				my $indent2 = length("$1");
				if ( $indent->[-1] >= $indent2 ) {
					# Null hash entry
					$hash->{$key} = undef;
				} else {
					$hash->{$key} = {};
					_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
				}
			}
		}
	}

	return 1;
}

package App::cpanminus::script;

__END__
