#!/usr/bin/perl

use strict;
use warnings;
use Config;
use POSIX ();
use Cwd;
use ExtUtils::MakeMaker;
use Data::Dumper;

our $VERSION = "1.00";

my $cpan = "www.cpan.org";
my $cdir0 = "~/.cpanx";
my $cdir = glob($cdir0);
my $orig_cwd = Cwd::cwd();
my %modules_hash;
my $got_package_details;
my @install;
my $mm_opt = "";
my $mb_opt = "";
my %file_hash;
my %package_hash;
my %packages;
my %opts = (
    action => "install",
    test => 1,
    sudo => 1,
    interactive => 1,
    dependencies_only => 0,
);

get_opts();
setup_program();
get_cpan_mirror();

if ($opts{action} eq "mirror") {
    choose_mirror();
}
elsif ($opts{action} eq "look") {
    look_at_module();
}
elsif ($opts{action} eq "perldoc") {
    display_perldoc();
}
elsif ($opts{action} eq "info") {
    display_info_cmd();
}
elsif ($opts{action} eq "display_installation_files") {
    display_installation_files();
}
elsif ($opts{action} eq "clean") {
    clean_module_cache();
}
elsif ($opts{action} eq "version") {
    display_version();
}
elsif ($opts{action} eq "list_modules") {
    list_modules();
}
elsif ($opts{action} eq "list_packages") {
    list_packages();
}
elsif ($opts{action} eq "where") {
    display_where();
}
elsif ($opts{action} eq "uninstall") {
    uninstall_module();
}
elsif ($opts{action} eq "install") {
    install_module();
}

sub setup_program {
    if (!-e "$cdir") {
        mkdir "$cdir" or die "Can't create $cdir directory: $!";
    }
    if (!-e "$cdir/data") {
        mkdir "$cdir/data" or die "Can't create $cdir/data directory: $!";
    }
    chdir $cdir or die "Can't chdir to $cdir: $!";

    # Make sure END block is executed after ^C or a kill
    $SIG{INT} = sub {exit;};
    $SIG{TERM} = sub {exit;};
    END {
        unlink "$cdir/data/output.$$";
        unlink "$cdir/data/headers.$$";
        unlink "$cdir/data/content.$$";
    }
}

sub display_where {
    my $arg = $opts{module};
    my $file = $arg;
    $file =~ s{::}{/}g;
    $file .= ".pm";
    for my $dir (@INC) {
        $dir =~ s{/+$}{};
        next if $dir eq ".";
        if (-e "$dir/$file") {
            print "$dir/$file\n";
            if (!$opts{all}) {
                last;
            }
        }
    }
}

sub list_modules_in_dir {
    my ($dir, $top) = @_;
    my $dh;
    my $retval = opendir $dh, "$top$dir";
    if (!$retval) {
        print STDERR "Can't opendir '$top$dir': $!\n";
        return;
    }
    for my $name (readdir $dh) {
        next if $name =~ /^\.\.?$/;
        my $file = "$top$dir/$name";
        if (-d $file) {
            if (!-l $file) {
                list_modules_in_dir("$dir/$name", $top);
            }
        }
        else {
            next if $name !~ /\.(\w+)$/;
            my $ext = $1;
            if ($ext =~ /^(pm|pl|so|dylib|dll)$/) {
                if ($modules_hash{"$dir/$name"}) {
                    # duplicate
                    # print "$dir/$name\n";
                }
                $modules_hash{"$dir/$name"} = 1;
                if ($file_hash{$file}) {
                    next;
                }
                $file_hash{$file} = 1;
                print "$file\n";
            }
        }
    }
    close $dh;
}

sub list_modules {
    for my $dir (@INC) {
        next if $dir eq ".";
        list_modules_in_dir("", $dir);
    }
}

sub list_packages_in_dir {
    my ($dir, $top) = @_;
    my $dh;
    my $retval = opendir $dh, "$top$dir";
    if (!$retval) {
        print STDERR "Can't opendir '$top$dir': $!\n";
        return;
    }
    for my $name (readdir $dh) {
        next if $name =~ /^\.\.?$/;
        my $file = "$top$dir/$name";
        if (-d $file) {
            if (!-l $file) {
                list_packages_in_dir("$dir/$name", $top);
            }
        }
        else {
            next if $name !~ /\.pm$/;
            my $mname = "$dir/$name";
            $mname =~ s{^/+}{};
            $mname =~ s{/}{::}g;
            $mname =~ s{\.pm$}{};
            my $pname = $packages{$mname};
            next if !$pname;
            if ($package_hash{$pname}) {
                next;
            }
            $package_hash{$pname} = 1;
            print "$pname\n";
        }
    }
    close $dh;
}

sub list_packages {
    get_packages_details();
    my $file = "data/02packages.details.txt";
    open my $fh, "<", $file or die "Can't open $file: $!";
    my $version;
    my $path;
    while (my $line = <$fh>) {
        if ($line =~ /^(\S+)\s+(\S+)\s+(\S+)$/i) {
            my $mname = $1;
            my $mversion = $2;
            my $path = $3;
            if ($path =~ m{/([^/]+)$}) {
                my $fname = $1;
                if ($fname =~ /^([^.]+)-([\d.]+)\.([\w.]+)$/) {
                    my $pname = $1;
                    my $pversion = $2;
                    my $ext = $3;
                    $packages{$mname} = $pname;
                }
            }
        }
    }
    close $fh;
    for my $dir (@INC) {
        next if $dir eq ".";
        list_packages_in_dir("", $dir);
    }
}

sub get_module_count {
    my ($dir) = @_;
    if ($dir eq ".") {
        $dir = $orig_cwd;
    }
    my $count = `find -L $dir -name '*.pm' 2>/dev/null | wc -l`;
    $count =~ s/\s+$//;
    return $count;
}

sub display_version {
    print "cpanx version $VERSION location $0\n";
    print "perl version $] location $^X\n\n";

    print "%Config:\n";
    my @keys = (
        "installarchlib",    "installprivlib",   "installbin",
        "installsitearch",   "installsitelib",   "installsitebin",
        "installvendorarch", "installvendorlib", "installvendorbin"
    );
    for my $key (@keys) {
        my $value = $Config{$key} || "";
        print "$key $value";
        if ($opts{with_counts} && $key =~ /(arch|lib)$/) {
            my $count = get_module_count($value);
            print " ($count modules)";
        }
        print "\n";
    }

    # print "\n%ENV:\n";
    # for my $key (sort keys %ENV) {
    #     next if $key !~ /^PERL/;
    #     my $value = $ENV{$key} || "";
    #     print "$key $value\n";
    # }

    my %perl5lib;
    my $str = $ENV{PERL5LIB} || "";
    for my $dir (split /:/, $str) {
        $perl5lib{$dir} = 1;
    }
    my $seen_non_perl5lib = 0;

    print "\n\@INC:\n";
    for my $dir (@INC) {
        if (!$seen_non_perl5lib && !$perl5lib{$dir}) {
            $seen_non_perl5lib = 1;
            print "--\n";
        }
        print "$dir";
        if ($opts{with_counts}) {
            my $count = get_module_count($dir);
            print " ($count modules)";
        }
        print "\n";
    }
}

sub clean_module_cache {
    runcmd("find * -maxdepth 0 ! -name data -exec rm -rvf {} \\;");
}

sub display_perldoc {
    my $module = init_main_module();
    if (!$module->{name}) {
        get_meta_data($module);
    }
    my $file;
    if ($module->{name}) {
        $file = $module->{name};
        $file =~ s{::}{/}g;
        $file = "lib/$file.pm";
    }
    if (!$file || !-e $file) {
        my $output = `find *.pm lib -name '*.pm' 2>/dev/null | sort | head -1`;
        $output =~ s/^\s+|\s+$//g;
        $file = $output;
    }
    if (!$file) {
        die "Unable to find main module for this distribution.\n";
    }
    print "Displaying perldoc for $file\n";
    system "perldoc $file";
}

sub uninstall_module {
    my $arg = $opts{module};
    if (!$arg) {
        die "A module is required.\n";
    }
    my $file = $arg;
    $file =~ s{::}{/}g;
    $file = "auto/$file/.packlist";
    my $packlist = find_file_in_INC($file);
    if (!$packlist) {
        die "Unable to find .packlist file\n";
    }
    open my $fh, "<", $packlist or die "Can't open $packlist: $!";
    my $content = do {local $/; <$fh>};
    close $fh;
    print "The following files will be removed:\n";
    print "$content$packlist\n";
    if ($opts{interactive}) {
        print STDERR "\nDo you want to uninstall? [n] ";
        my $input = <STDIN>;
        chomp $input;
        $input ||= "n";
        if ($input !~ /^(y|yes)$/i) {
            print "Not uninstalling.\n";
            exit;
        }
    }
    my $cmd = "(cat $packlist; echo $packlist) | xargs ";
    if ($opts{sudo}) {
        $cmd .= "sudo "
    }
    $cmd .= "rm -rvf";
    runcmd($cmd);
}

sub install_module {
    my $module = init_main_module();
    get_module_info($module);
    display_info($module);
    if (!@install) {
        exit;
    }
    if (!$module->{install} && !$opts{dependencies_only}) {
        exit;
    }
    if ($opts{interactive}) {
        print STDERR "\nDo you want to install? [n] ";
        my $input = <STDIN>;
        chomp $input;
        $input ||= "n";
        if ($input !~ /^(y|yes)$/i) {
            print "Not installing.\n";
            exit;
        }
    }
    for my $module (@install) {
        print "\n";
        chdir $module->{dir} or die "Can't chdir to $module->{dir}: $!";
        if (!$module->{configured}) {
            run_configure($module);
        }
        run_make($module);
        if ($opts{test}) {
            run_tests($module);
        }
        run_make_install($module);
        chdir $cdir or die "Can't chdir to $cdir: $!";
    }
}

sub get_module_info {
    my ($module) = @_;
    get_meta_data($module);
    get_installed_version($module);
    get_prereqs($module);
    for my $prereq (@{$module->{prereqs}}) {
        process_prereq($prereq);
    }
    if (!$module->{installed_version} || $module->{installed_version} ne $module->{version} || $opts{reinstall}) {
        $module->{install} = 1;
    }
    if (!$opts{dependencies_only}) {
        push @install, $module;
    }
}

sub display_info_cmd {
    my $module = init_main_module();
    get_module_info($module);
    display_info($module);
}

sub display_installation_files {
    my $module = init_main_module();
    get_module_info($module);
    print "\n";
    if (!$module->{install}) {
        my $inst = installed_str($module);
        print "Nothing to install. $module->{name} is up to date ($inst)\n";
    }
    else {
        print "The following files will be installed:\n";
    }
    for my $module (@install) {
        print "\n";
        print "$module->{name}\n";
        chdir $module->{dir} or die "Can't chdir to $module->{dir}: $!";
        if (!$module->{configured}) {
            eval {
                run_configure($module, 1);
            };
            next if $@;
        }
        run_make($module, 1);
        if (-e "Makefile") {
            my $output = `make -n install`;
            if ($output =~ /-MExtUtils::Install -e '(.*?)' -- \\\n(.*?)^\S/ims) {
                my $cmd = $1;
                my $args = $2;
                my @args;
                while ($args =~ /"([^"]*)"|(\S+)/gc) {
                    my $arg = $1 || $2;
                    next if $arg eq "\\";
                    push @args, $arg;
                }
                my %args = @args;
                for my $dir (sort keys %args) {
                    next if $dir !~ /^blib\//;
                    my $dir2 = $args{$dir};
                    next if $dir2 eq "none";
                    my $output2 = `find $dir -mindepth 1 -type f ! -name .exists`;
                    $output2 =~ s{^$dir}{$dir2}gm;
                    print "$output2";
                }
                if ($args{write}) {
                    print "$args{write}\n";
                }
            }
        }
        elsif (-e "Build") {
            my $output = `$^X Build fakeinstall 2>/dev/null`;
            while ($output =~ /(Installing|Writing) (.*)/gim) {
                my $file = $2;
                print "$file\n";
            }
        }
    }
}

sub run_make {
    my ($module, $quiet) = @_;
    if (-e "Makefile") {
        my $cmd = "make";
        $cmd .= " >/dev/null 2>&1" if $quiet;
        runcmd($cmd, undef, $quiet);
        if ($? != 0) {
            die "Make failed.\n";
        }
    }
    elsif (-e "Build") {
        my $cmd = "$^X Build";
        $cmd .= " >/dev/null 2>&1" if $quiet;
        runcmd($cmd, undef, $quiet);
        if ($? != 0) {
            die "Build failed.\n";
        }
    }
}

sub run_tests {
    my ($module) = @_;
    if (-e "Makefile") {
        my $cmd = "make test";
        runcmd($cmd);
        if ($? != 0) {
            die "Make test failed.\n";
        }
    }
    elsif (-e "Build") {
        my $cmd = "$^X Build test";
        runcmd($cmd);
        if ($? != 0) {
            die "Build test failed.\n";
        }
    }
    else {
        die "Makefile or Build file not found.\n";
    }
}

sub run_make_install {
    my ($module) = @_;
    if (-e "Makefile") {
        my $cmd = "make install";
        if ($opts{sudo}) {
            $cmd = "sudo $cmd";
        }
        runcmd($cmd);
        if ($? != 0) {
            die "Make install failed.\n";
        }
    }
    elsif (-e "Build") {
        my $cmd = "$^X Build install";
        if ($opts{sudo}) {
            $cmd = "sudo $cmd";
        }
        runcmd($cmd);
        if ($? != 0) {
            die "Build install failed.\n";
        }
    }
    else {
        die "Makefile or Build file not found.\n";
    }
}

sub display_info {
    my ($module) = @_;
    my $inst = installed_str($module);
    print "\n$module->{metaname} $module->{version} ($inst)\n";
    my $meta = $module->{meta};
    if ($meta->{abstract}) {
        print "$meta->{abstract}\n";
    }
    if ($meta->{author}) {
        print "By " . join(", ", @{$meta->{author}}) . "\n";
    }
    if ($meta->{resources} && $meta->{resources}{repository}) {
        my $repo = $meta->{resources}{repository};
        if ($repo && ref $repo) {
            if ($repo->{web}) {
                print "Repository $repo->{web}\n";
            }
            elsif ($repo->{url}) {
                print "Repository $repo->{url}\n";
            }
        }
        else {
            print "Repository $repo\n";
        }
    }
    print "\nDependencies:\n";
    for my $prereq (@{$module->{prereqs}}) {
        display_prereq_info($prereq);
    }
    print "\nInstall Order:\n";
    if ($module->{install}) {
        if ($opts{dependencies_only} && !@install) {
            print "Nothing. No uninstalled dependencies.\n";
        }
        for my $prereq (@install) {
            $inst = installed_str($prereq);
            print "$prereq->{metaname} $prereq->{version} ($inst)\n";
        }
    }
    else {
        $inst = installed_str($module);
        print "Nothing. $module->{metaname} is up to date ($inst)\n";
    }
}

sub installed_str {
    my ($module) = @_;
    my $inst = "";
    if ($module->{installed_version}) {
        $inst = "have $module->{installed_version}";
    }
    else {
        $inst = "not installed";
    }
    return $inst;
}

sub process_prereq {
    my ($module) = @_;
    get_installed_version($module);
    if ($module->{installed_version} && $module->{installed_version} ge $module->{version_needed}) {
        return;
    }
    if ($modules_hash{$module->{name}}) {
        return;
    }
    $modules_hash{$module->{name}} = $module;
    $module->{install} = 1;

    chdir $cdir or die "Can't chdir to $cdir: $!";
    eval {
        download_module_named($module);
    };
    if ($@) {
        print $@;
        return;
    }

    chdir $module->{dir} or die "Can't chdir to $module->{dir}: $!";
    get_meta_data($module);
    get_prereqs($module);
    for my $prereq (@{$module->{prereqs}}) {
        process_prereq($prereq);
    }
    push @install, $module;
}

sub display_prereq_info {
    my ($module) = @_;
    my $inst = installed_str($module);
    my $star = $module->{install} ? " *" : "";
    my $indent = " " x (($module->{depth} - 1) * 4);
    print "$indent$module->{name} $module->{version_needed} ($inst)$star\n";
    for my $prereq (@{$module->{prereqs}}) {
        display_prereq_info($prereq);
    }
}

sub get_installed_version {
    my ($module) = @_;
    $module->{installed_version} = undef;
    if ($module->{name}) {
        if ($module->{name} eq "perl") {
            $module->{installed_version} = $];
        }
        else {
            my $file = find_module_in_INC($module->{name});
            if ($file) {
                my $installed_version = MM->parse_version($file);
                $module->{installed_version} = $installed_version;
            }
        }
    }
}

sub find_file_in_INC {
    my ($file) = @_;
    for my $dir (@INC) {
        $dir =~ s{/+$}{};
        next if $dir eq ".";
        if (-e "$dir/$file") {
            return "$dir/$file";
        }
    }
    return undef;
}

sub find_module_in_INC {
    my ($name) = @_;
    my $file = $name;
    $file =~ s{::}{/}g;
    $file .= ".pm";
    my $file2 = find_file_in_INC($file);
    return $file2;
}

sub get_prereqs {
    my ($module) = @_;
    my $meta = $module->{meta};
    my @prereqs;
    if ($meta->{prereqs}) {
        for my $type (keys %{$meta->{prereqs}}) {
            for my $type2 (keys %{$meta->{prereqs}{$type}}) {
                for my $name (keys %{$meta->{prereqs}{$type}{$type2}}) {
                    my $version = $meta->{prereqs}{$type}{$type2}{$name};
                    my $prereq = {name => $name, version_needed => $version, type => $type};
                    $prereq->{opt} = 1 if $type2 ne "requires";
                    push @prereqs, $prereq;
                }
            }
        }
    }
    for my $key (keys %$meta) {
        if ($key =~ /^((\w+)_)?requires$/) {
            next if !$meta->{$key} || !ref $meta->{$key};
            my $type = $2;
            for my $name (keys %{$meta->{$key}}) {
                my $version = $meta->{$key}{$name};
                my $prereq = {name => $name, version_needed => $version, type => $type};
                push @prereqs, $prereq;
            }
        }
    }

    # There are prereqs for different types like test or runtime or
    # develop, this loop will combine all types into one prereq with a
    # list of it's types inside.
    my %prereqs;
    for my $tprereq (@prereqs) {
        next if $tprereq->{opt};
        my $type = $tprereq->{type} || "";
        next if $type =~ /^(develop|x_dist_zilla)$/i;
        my $prereq;
        if ($prereqs{$tprereq->{name}}) {
            $prereq = $prereqs{$tprereq->{name}};
        }
        else {
            $prereq = {
                name => $tprereq->{name},
                version_needed => $tprereq->{version_needed},
                type => [],
                depth => $module->{depth} + 1,
            };
            $prereq->{opt} = 1 if $tprereq->{opt};
            $prereqs{$prereq->{name}} = $prereq;
        }
        if ($type) {
            push @{$prereq->{type}}, $type;
        }
        if (!$tprereq->{opt}) {
            delete $prereq->{opt};
        }
    }

    my @prereqs_sorted;
    for my $name (sort keys %prereqs) {
        push @prereqs_sorted, $prereqs{$name};
    }
    $module->{prereqs} = \@prereqs_sorted;
}

sub process_meta_data {
    my ($module, $meta) = @_;
    $module->{meta} = $meta;
    $module->{version} = $meta->{version};
    if ($meta->{name}) {
        my $name = $meta->{name};
        $name =~ s/-/::/g;
        $module->{name} ||= $name;
        $module->{metaname} = $name;
    }
}

sub run_configure {
    my ($module, $quiet) = @_;
    $module->{configured} = 1;
    if (-e "Makefile.PL") {
        my $cmd = "$^X Makefile.PL$mm_opt";
        $cmd .= " >/dev/null </dev/null" if $quiet;
        runcmd($cmd, undef, $quiet);
        if ($? != 0) {
            die "Configure failed.\n";
        }
    }
    elsif (-e "Build.PL") {
        my $cmd = "$^X Build.PL$mb_opt";
        $cmd .= " >/dev/null </dev/null" if $quiet;
        runcmd($cmd, undef, $quiet);
        if ($? != 0) {
            die "Configure failed.\n";
        }
    }
    else {
        die "No configure script found (Makefile.PL or Build.PL)\n";
    }
}

sub get_meta_data {
    my ($module) = @_;
    for my $file ("META.json", "MYMETA.json") {
        if (-e $file) {
            open my $fh, "<", $file or die "Can't open $file: $!";
            my $content = do {local $/; <$fh>};
            close $fh;
            if ($module->{name} && $module->{name} =~ /^JSON::DWIW$/) {
                $content =~ s/'/"/g;
                $content =~ s/,\s*\}/\}/g;
            }
            my $meta = parse_json($content);
            process_meta_data($module, $meta);
            return $meta;
        }
    }
    my $file = "META.yml";
    if (-e $file) {
        open my $fh, "<", $file or die "Can't open $file: $!";
        my $content = do {local $/; <$fh>};
        close $fh;
        my $meta = parse_yaml($content);
        process_meta_data($module, $meta);
        return $meta;
    }
    run_configure($module);
    $file = "MYMETA.json";
    if (-e $file) {
        open my $fh, "<", $file or die "Can't open $file: $!";
        my $content = do {local $/; <$fh>};
        close $fh;
        my $meta = parse_json($content);
        process_meta_data($module, $meta);
        return $meta;
    }
    die "Can't find META.json or MYMETA.json.\n";
}

sub look_at_module {
    my $module = init_main_module();
    print "Entering module's directory\n";
    my $shell = $ENV{SHELL} || "sh";
    system "$shell";
}

sub get_packages_details {
    return if $got_package_details;
    $got_package_details = 1;

    # We want it to fetch this file new even if the file exists locally
    # because it's contents might have changed, but only do this the
    # first time this function is called during the run of the script.
    my $rfile = download("/modules/02packages.details.txt.gz", "data");
    my $file = "data/02packages.details.txt";
    my $cmd = "gzip -d -c -f $rfile >$file";
    runcmd($cmd);
}

sub init_main_module {
    my $module = {};
    my $arg = $opts{module};
    if (!$arg) {
        die "A module is required.\n";
    }
    $module->{main} = 1;
    $module->{depth} = 0;
    if ($arg =~ m{^/|\./}) {
        # Local directory
        my $dir = $arg;
        if ($dir !~ m{^/}) {
            $dir = "$orig_cwd/$dir";
        }
        if (!-e $dir) {
            die "Directory \"$dir\" does not exist.\n";
        }
        elsif (!-d $dir) {
            die "Arg \"$dir\" must be a directory.\n";
        }
        $module->{dir} = $dir;
    }
    elsif ($arg =~ m{^((\w)(\w)[^/]*)/(.*)}) {
        # Looks like AUTHOR/Module.tar.gz
        my $a = $2;
        my $b = $3;
        my $author = $1;
        my $file = $4;
        my $path = "/modules/by-authors/id/$a/$a$b/$author/$file";
        my $dir = download_module($path);
        $module->{dir} = $dir;
        $module->{cpan} = $path;
    }
    elsif ($arg =~ /^(\w+)[^.]*\./) {
        # Looks like Module.tar.gz
        my $part = $1;
        my $path = "/modules/by-module/$part/$arg";
        my $dir = download_module($path);
        $module->{dir} = $dir;
        $module->{cpan} = $path;
    }
    else {
        # Looks like Module::Module
        $modules_hash{$arg} = $module;
        $module->{name} = $arg;
        download_module_named($module);
    }
    chdir $module->{dir} or die "Can't chdir to $module->{dir}: $!";
    return $module;
}

sub download_module_named {
    my ($module) = @_;
    if ($module->{name} =~ /^(perl|Config|Errno)$/i) {
        die "Skipping $module->{name} module.\n";
    }
    get_packages_details();
    my $file = "data/02packages.details.txt";
    open my $fh, "<", $file or die "Can't open $file: $!";
    my $version;
    my $path;
    while (my $line = <$fh>) {
        if ($line =~ /^$module->{name}\s+(\S+)\s+(\S+)$/i) {
            $version = $1;
            $path = $2;
            last;
        }
    }
    close $fh;
    if (!$path) {
        die "Can't find $module->{name} module.\n";
    }
    if ($path =~ m{/perl-[^/]+$}) {
        die "Skipping $module->{name} module in Perl source.\n";
    }
    $path = "/modules/by-authors/id/$path";
    my $dir = download_module($path);
    $module->{dir} = $dir;
    $module->{cpan} = $path;
}

# Given a cpan path like /modules/by-authors/id/foo-1.2.3.tar.gz
# This will download it, extract it, then return a local relative path
# like foo-1.2.3
sub download_module {
    my ($path) = @_;
    $path =~ m{/([^/]+)$};
    my $name = $1;
    my $dir;
    if ($name =~ /(.+)\.tar\.gz$/) {
        $dir = $1;
    }
    elsif ($name =~ /(.+)\.tgz$/) {
        $dir = $1;
    }
    else {
        die "Unknown file format \"$name\".\n";
    }
    my $rfile = download($path, "", 1);
    if (!-e $dir) {
        my $cmd = "tar -x -v -f $rfile";
        runcmd($cmd);
    }
    $dir = "$cdir/$dir";
    return $dir;
}

sub choose_mirror {
    # The mirror list seemed to have moved to http://mirrors.cpan.org/cpan-json.txt
    # and is not inside the cpan repo anymore.
    my $file = download("/indices/mirrors.json", "data");
    open my $fh, "<", $file or die "Can't open $file: $!";
    my %hash;
    my @mirrors;
    my $index = 0;
    while (my $line = <$fh>) {
        if ($line =~ m{^\s*"http"\s*:\s*"([^"]+)"}m) {
            my $url = $1;
            $url =~ s{/+$}{};
            next if $hash{$url};
            $hash{$url} = 1;
            $index++;
            push @mirrors, {index => $index, url => $url};
        }
    }
    close $fh;
    print "There are $index CPAN mirrors:\n\n";

    $file = "data/mirrorsping.txt";
    open $fh, ">", $file or die "Can't open $file: $!";
    my $max_children = 50;
    my $num_children = 0;
    for my $mirror (@mirrors) {
        if ($num_children >= $max_children) {
            wait();
            $num_children--;
        }
        my $pid = fork();
        if (!defined $pid) {
            die "Can't fork: $!";
        }
        elsif ($pid != 0) {
            $num_children++;
        }
        else {
            $mirror->{url} =~ m{^\w+://([^/]+)};
            my $host = $1;
            my $output = `ping $host -c 1 -t 2`;
            my $ttl;
            my $time;
            if ($output =~ /ttl=(\d+) time=([\d\.]+) ms$/m) {
                $ttl = $1;
                $time = $2;
                print "$mirror->{index} $mirror->{url} time=$time ms\n";
            }
            else {
                $time = 999;
                print "$mirror->{index} $mirror->{url} [timed out]\n";
            }
            print $fh "$time $mirror->{index} $mirror->{url}\n";
            exit;
        }
    }
    close $fh;
    while ($num_children) {
        wait();
        $num_children--;
    }
    system "sort -n $file > $file.sorted; mv $file.sorted $file;";
    open $fh, "<", $file or die "Can't open $file: $!";
    while (my $line = <$fh>) {
        if ($line =~ /^([\d.]+)\s+(\d+)\s+(.*)/) {
            my $time = $1;
            my $index = $2;
            my $url = $3;
            $mirrors[$index - 1]{time} = $time;
        }
    }
    close $fh;
    my @mirrors2 = sort {
        ($a->{time} || 999) <=> ($b->{time} || 999)
    } @mirrors;

    print "\nBest mirrors by response time:\n";
    for my $index (0 .. 9) {
        my $mirror = $mirrors2[$index];
        last if !$mirror || $mirror->{timeout};
        print "$mirror->{index} $mirror->{url} time=$mirror->{time} ms\n";
    }
    print "\nWhich mirror do you want (number)? ";
    my $input = <STDIN>;
    $input =~ s/^\s+|\s+$//g;

    my $url = undef;
    if ($input =~ /^(\d+)$/) {
        my $index = $1;
        my $mirror = $mirrors[$index - 1];
        if ($mirror) {
            $url = $mirror->{url};
        }
    }
    else {
        print "Making no changes.\n";
    }

    if ($url) {
        print "Setting mirror to $url\n";
        my $file = "data/mirror.txt";
        open my $fh, ">", $file or die "Can't open $file: $!";
        print $fh "$url\n";
        close $fh;
    }
}

# Given a cpan path like /modules/by-authors/id/foo.tar.gz
# This will download it to $dir/foo.tar.gz and return that file name
sub download {
    my ($path, $dir, $file_doesnt_change) = @_;
    $path =~ m{/([^/]+)$};
    my $name = $1;
    my $file = $name;
    if ($dir) {
        $file = "$dir/$file";
    }
    my $newer = "";

    if (-e $file) {
        if ($file_doesnt_change) {
            print "Using cached $file\n";
            return $file;
        }
        $newer .= "-z $file ";
    }

    my $ofile = "data/output.$$";
    my $hfile = "data/headers.$$";
    my $cfile = "data/content.$$";

    # The -R option makes curl try to figure out the mtime of the remote
    # file and give it to $cfile, so next time if we want to download
    # the file it won't if it's not newer than what we have.
    my $show_cmd = "curl $cpan$path";
    my $cmd = "$show_cmd $newer-R --connect-timeout 5 -o $cfile -D $hfile 2>&1 | tee $ofile";
    runcmd($cmd, $show_cmd);

    open my $fh, "<", $ofile or die "Can't open $ofile: $!";
    my $output = do {local $/; <$fh>};
    close $fh;
    open my $fh2, "<", $hfile or die "Can't open $hfile: $!";
    my $headers = do {local $/; <$fh2>};
    close $fh2;
    if ($output =~ /(curl: .*)\n\z/m) {
        exit;
    }
    if ($headers =~ /^HTTP\S*\s+(\d+)(\s+([^\r\n]*))?/i) {
        my $code = $1;
        my $mesg = $3;
        if ($code == 304) {
            # Not Modified
            return $file;
        }
        elsif ($code != 200) {
            my $mesg2 = $code;
            $mesg2 .= " $mesg" if $mesg;
            die "$mesg2\n";
        }
    }
    rename $cfile, $file or die "Can't rename $cfile -> $file: $!";
    return $file;
}

sub get_cpan_mirror {
    if ($opts{cpan}) {
        $cpan = $opts{cpan};
    }
    else {
        my $file = "data/mirror.txt";
        if (-e $file) {
            $cpan = `cat $file` or exit;
        }
    }
    if ($cpan =~ /(\S+)/) {
        $cpan = $1;
    }
    if ($cpan !~ m{^\w+://}) {
        $cpan = "http://$cpan";
    }
}

sub parse_json_str {
    my ($str, $val) = @_;
    if ($$str !~ /\G\s*"/gc) {
        return 0;
    }
    $$val = "";
    while (1) {
        if ($$str =~ /\G([^"\\]+)/gc) {
            $$val .= $1;
        }
        elsif ($$str =~ /\G\\u([0-9a-f]{4})/gci) {
            $$val .= chr(hex($1));
        }
        elsif ($$str =~ /\G\\(.)/gc) {
            my $char = $1;
            if ($char eq "b") {
                $$val .= "\b";
            }
            elsif ($char eq "f") {
                $$val .= "\f";
            }
            elsif ($char eq "n") {
                $$val .= "\n";
            }
            elsif ($char eq "r") {
                $$val .= "\r";
            }
            elsif ($char eq "t") {
                $$val .= "\t";
            }
            else {
                $$val .= $char;
            }
        }
        elsif ($$str =~ /\G"/gc) {
            return 1;
        }
        else {
            die "Expected \"\n";
        }
    }
    return 0;
}

sub parse_json_hash {
    my ($str, $val) = @_;
    if ($$str !~ /\G\s*\{/gc) {
        return 0;
    }
    my $val2;
    my @values;
    while (1) {
        if (!parse_json_str($str, \$val2)) {
            last;
        }
        push @values, $val2;
        if ($$str !~ /\G\s*:/gc) {
            die "Expected :\n";
        }
        if (!parse_json_value($str, \$val2)) {
            die "Expected value.\n";
        }
        push @values, $val2;
        if ($$str !~ /\G\s*,/gc) {
            last;
        }
    }
    if ($$str !~ /\G\s*\}/gc) {
        die "Expected }\n";
    }
    $$val = {@values};
    return 1;
}

sub parse_json_array {
    my ($str, $val) = @_;
    if ($$str !~ /\G\s*\[/gc) {
        return 0;
    }
    my $val2;
    my @values;
    while (1) {
        if (!parse_json_value($str, \$val2)) {
            last;
        }
        push @values, $val2;
        if ($$str !~ /\G\s*,/gc) {
            last;
        }
    }
    if ($$str !~ /\G\s*\]/gc) {
        die "Expected ]\n";
    }
    $$val = \@values;
    return 1;
}

sub parse_json_number {
    my ($str, $val) = @_;
    if ($$str !~ /\G\s*(-?\d+(\.\d*)?(e[+-]?\d+)?)/gci) {
        return 0;
    }
    $$val = $1 + 0;
    return 1;
}

sub parse_json_keyword {
    my ($str, $val) = @_;
    if ($$str =~ /\G\s*null/gci) {
        $$val = undef;
        return 1;
    }
    elsif ($$str =~ /\G\s*true/gci) {
        $$val = 1;
        return 1;
    }
    elsif ($$str =~ /\G\s*false/gci) {
        $$val = 0;
        return 1;
    }
    else {
        return 0;
    }
}

sub parse_json_value {
    my ($str, $val) = @_;
    if (parse_json_hash($str, $val)) {
        return 1;
    }
    elsif (parse_json_array($str, $val)) {
        return 1;
    }
    elsif (parse_json_str($str, $val)) {
        return 1;
    }
    elsif (parse_json_number($str, $val)) {
        return 1;
    }
    elsif (parse_json_keyword($str, $val)) {
        return 1;
    }
    else {
        return 0;
    }
}

sub parse_json {
    my ($str) = @_;
    my $val;
    parse_json_value(\$str, \$val);
    if ($str =~ /\S/gc) {
        die "Unexpected character\n";
    }
    return $val;
}

sub unquote_str {
    my ($str) = @_;
    my $str2;
    if ($str =~ /^"/) {
        parse_json_str(\$str, \$str2);
    }
    elsif ($str =~ /^'(.*)'/) {
        $str2 = $1;
    }
    else {
        $str2 = $str;
    }
    return $str2;
}

sub parse_yaml {
    my ($str) = @_;
    $str =~ s/\r//g;
    my $top = {
        indent => -1,
    };
    my $val = $top;
    while ($str =~ /\G([ ]*)(.*)\n/gm) {
        my $indent = length($1);
        my $content = $2;
        next if $content =~ /^---|^\s*#|^\s*$/;
        my $val2 = {indent => $indent};
        if ($content =~ /^-(\s+|$)(.*)/) {
            $val2->{type} = "li";
            $val2->{value} = $2;
            $val2->{value} = unquote_str($val2->{value});
        }
        elsif ($content =~ /^(.*?)\s*:(\s+|$)(.*)/) {
            $val2->{type} = "keyval";
            $val2->{key} = $1;
            $val2->{value} = $3;
            $val2->{key} = unquote_str($val2->{key});
            $val2->{value} = unquote_str($val2->{value});
        }
        else {
            die "Unknown YAML content \"$content\"\n";
        }
        my $parent = $val;
        while ($parent) {
            if ($indent > $parent->{indent}) {
                $val2->{parent} = $parent;
                push @{$parent->{children}}, $val2;
                last;
            }
            $parent = $parent->{parent};
        }
        $val = $val2;
    }
    clean_yaml($top);
    return $top->{value};
}

sub clean_yaml {
    my ($obj) = @_;
    if ($obj->{children}) {
        my $obj2 = $obj->{children}[0];
        if ($obj2->{type} eq "li") {
            $obj->{value} = [];
            for my $obj2 (@{$obj->{children}}) {
                clean_yaml($obj2);
                push @{$obj->{value}}, $obj2->{value};
            }
        }
        elsif ($obj2->{type} eq "keyval") {
            $obj->{value} = {};
            for my $obj2 (@{$obj->{children}}) {
                clean_yaml($obj2);
                $obj->{value}{$obj2->{key}} = $obj2->{value};
            }
        }
    }
}

sub runcmd {
    my ($cmd, $show_cmd, $quiet) = @_;
    $show_cmd ||= $cmd;
    if ($quiet) {
        system $cmd;
    }
    else {
        print "$show_cmd\n";
        system $cmd;
        print "\n";
    }
}

sub add_configure_opt {
    my ($opt, $path) = @_;
    if (!defined $path) {
        die "Invalid -$opt argument\n";
    }
    if ($opt eq "I") {
        $mm_opt .= " INSTALL_BASE=\"$path\"";
        $mb_opt .= " --install_base \"$path\"";
    }
    elsif ($opt eq "L") {
        my $arch = $Config{archname};
        $mm_opt .= " INSTALLPRIVLIB=\"$path\" INSTALLSITELIB=\"$path\"";
        $mm_opt .= " INSTALLARCHLIB=\"$path/$arch\" INSTALLSITEARCH=\"$path/$arch\"";
        $mb_opt .= " --install_path lib=\"$path\"";
        $mb_opt .= " --install_path arch=\"$path/$arch\"";
    }
    elsif ($opt eq "LL") {
        $mm_opt .= " INSTALLPRIVLIB=\"$path\" INSTALLSITELIB=\"$path\"";
        $mm_opt .= " INSTALLARCHLIB=\"$path\" INSTALLSITEARCH=\"$path\"";
        $mb_opt .= " --install_path lib=\"$path\"";
        $mb_opt .= " --install_path arch=\"$path\"";
    }
    elsif ($opt eq "B") {
        $mm_opt .= " INSTALLBIN=\"$path\" INSTALLSITEBIN=\"$path\"";
        $mb_opt .= " --install_path bin=\"$path\"";
    }
    elsif ($opt eq "SC") {
        $mm_opt .= " INSTALLSCRIPT=\"$path\" INSTALLSITESCRIPT=\"$path\"";
        $mb_opt .= " --install_path script=\"$path\"";
    }
    elsif ($opt eq "M1") {
        $mm_opt .= " INSTALLMAN1DIR=\"$path\" INSTALLSITEMAN1DIR=\"$path\"";
        $mb_opt .= " --install_path bindoc=\"$path\"";
    }
    elsif ($opt eq "M3") {
        $mm_opt .= " INSTALLMAN3DIR=\"$path\" INSTALLSITEMAN3DIR=\"$path\"";
        $mb_opt .= " --install_path libdoc=\"$path\"";
    }
}

sub get_opts {
    my @args;
    while (my $arg = shift @ARGV) {
        if ($arg =~ /^--?$/) {
            push @args, @ARGV;
            last;
        }
        elsif ($arg =~ /^(--?help|-h)$/) {
            usage();
        }
        elsif ($arg eq "-g") {
            $opts{action} = "list_modules";
        }
        elsif ($arg eq "-G") {
            $opts{action} = "list_packages";
        }
        elsif ($arg eq "-m") {
            $opts{cpan} = shift(@ARGV);
        }
        elsif ($arg eq "-M") {
            $opts{action} = "mirror";
        }
        elsif ($arg eq "-l") {
            $opts{action} = "look";
        }
        elsif ($arg eq "-p") {
            $opts{action} = "perldoc";
        }
        elsif ($arg eq "-i") {
            $opts{action} = "info";
        }
        elsif ($arg eq "-f") {
            $opts{action} = "display_installation_files";
        }
        elsif ($arg eq "-c") {
            $opts{action} = "clean";
        }
        elsif ($arg =~ /^-[vV]$/) {
            $opts{action} = "version";
            if ($arg eq "-V") {
                $opts{with_counts} = 1;
            }
        }
        elsif ($arg eq "-u") {
            $opts{action} = "uninstall";
        }
        elsif ($arg eq "-d") {
            $opts{dependencies_only} = 1;
        }
        elsif ($arg eq "-n") {
            $opts{interactive} = 0;
        }
        elsif ($arg eq "-S") {
            $opts{sudo} = 0;
        }
        elsif ($arg eq "-r") {
            $opts{reinstall} = 1;
        }
        elsif ($arg eq "-T") {
            $opts{test} = 0;
        }
        elsif ($arg =~ /^-[wW]$/) {
            $opts{action} = "where";
            if ($arg eq "-W") {
                $opts{all} = 1;
            }
        }
        elsif ($arg =~ /^-(I|LL|L|B|SC|M1|M3)$/) {
            my $opt = $1;
            my $path = shift(@ARGV);
            add_configure_opt($opt, $path);
        }
        elsif ($arg =~ /^-/) {
            die "Invalid argument '$arg'\n";
        }
        else {
            push @args, $arg;
        }
    }
    if (@args > 1) {
        die "Too many arguments\n";
    }
    $opts{module} = $args[0];
}

sub usage {
    print <<EOUSAGE;
Usage: cpanx [<options>] <module>

-c         clean module cache
-d         dependencies only
-f         displays info about what files would be installed
-g         displays list of globally installed modules
-G         displays list of globally installed packages
-h         displays this help text
-i         displays info about the module
-l         look at module's contents in a shell
-m <url>   sets the cpan mirror. default www.cpan.org
-M         choose a cpan mirror
-n         not interactive
-p         display perldoc for the module
-r         reinstall even if module is installed
-S         do not use sudo
-T         do not run tests
-u         uninstalls module
-v         displays version
-w         displays where a module is located
-W         displays all locations where a module is located

-I <loc>   sets install base path. e.g. /usr/local
-L <loc>   sets library install path. e.g. /Library/Perl/5.18
-LL <loc>  sets library install path including the architecture dependent dirs.
-B <loc>   sets the binary install path. e.g. ~/bin
-SC <loc>  sets the script install path. e.g. ~/scripts
-M1 <loc>  sets the man1 install path e.g. /usr/share/man/man1
-M3 <loc>  sets the man3 install path e.g. /usr/share/man/man3

<module>   name of the module you want to install
           e.g. DBD::mysql or DBD-mysql-4.046.tar.gz or ./
EOUSAGE
    exit;
}

__END__

=head1 NAME

cpanx - A CPAN downloader script

=head1 SYNOPSIS

    cpanx [<options>] [<module>]

=head1 OPTIONS

    -c         clean module cache
    -d         dependencies only
    -f         displays info about what files would be installed
    -g         displays list of globally installed modules
    -G         displays list of globally installed packages
    -h         displays this help text
    -i         displays info about the module
    -l         look at module's contents in a shell
    -m <url>   sets the cpan mirror. default www.cpan.org
    -M         choose a cpan mirror
    -n         not interactive
    -p         display perldoc for the module
    -r         reinstall even if module is installed
    -S         do not use sudo
    -T         do not run tests
    -u         uninstalls module
    -v         displays version
    -w         displays where a module is located
    -W         displays all locations where a module is located

    -I <loc>   sets install base path. e.g. /usr/local
    -L <loc>   sets library install path. e.g. /Library/Perl/5.18
    -LL <loc>  sets library install path including the architecture dependent dirs.
    -B <loc>   sets the binary install path. e.g. ~/bin
    -SC <loc>  sets the script install path. e.g. ~/scripts
    -M1 <loc>  sets the man1 install path e.g. /usr/share/man/man1
    -M3 <loc>  sets the man3 install path e.g. /usr/share/man/man3

    <module>   name of the module you want to install
               e.g. DBD::mysql or DBD-mysql-4.046.tar.gz or ./


=head1 DESCRIPTION

This program will download, display, and install modules (and their
dependencies) from CPAN. A public repository of user contributed
perl code.

This script is different to scripts like cpan and cpanm in that it
will show what it will do before it does anything. This is important
when a module has a lot of dependencies.

Just run something like "cpanx Module", it will download what it
needs, then display the dependencies in the order that they will
need to be installed to install the module.

Use the -i option, it will just show the information, and not ask
if you actually want to install it.

Use the -n option to set the script to not be interactive. It will
install without asking first.

Use the -S option to disable sudo during "make install".

If the module is up to date, you can use the -r option to reinstall.

If the tests aren't passing and you want to install anyway, use the
-T option.

Use the -d option to only install the dependencies, not the module
itself.

Use the -l option to open a shell in the module's directory and
then you can look around.

Use the -p option to open perldoc for the module.

The -f option can be used to display what files will be installed.
Use along with the -I, -L, -LL, -B, -SC, -M1, -M3 or the PERL_MM_OPT or
PERL_MB_OPT environment variables, to make sure you set the right
settings before you install.

You can uninstall the module with -u. It will show you what files
will be removed before actually removing them.

Set the CPAN mirror with the -m option. By default it uses
http://www.cpan.org.

Find the best CPAN mirror by running the command with -M. It will
ping all CPAN mirrors and show you the 10 servers with the best
time and let you choose which one you want.

Modules are cached and reused between calls, so you can look at the contents of the module in a shell, then get info about the install, then install the module and the module only downloads from cpan once. The cache is stored in ~/.cpanx.

This script has no dependencies. It uses the curl program to download.

This script is self contained. It's runnable if all you have is the one file.

=head1 EXAMPLE OUTPUT

    jacob@prism ~ $ cpanx Acme::MetaSyntactic
    curl http://www.cpan.org/modules/02packages.details.txt.gz -z /Users/jacob/.cpanx/02packages.details.txt.gz -R
      % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
				     Dload  Upload   Total   Spent    Left  Speed
    100 2028k  100 2028k    0     0   910k      0  0:00:02  0:00:02 --:--:--  911k
    curl http://www.cpan.org/modules/by-authors/id/B/BO/BOOK/Acme-MetaSyntactic-1.014.tar.gz -R
      % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
				     Dload  Upload   Total   Spent    Left  Speed
    100 56300  100 56300    0     0  70964      0 --:--:-- --:--:-- --:--:-- 70906
    tar -x -v -f ~/.cpanx/Acme-MetaSyntactic-1.014.tar.gz -C ~/.cpanx
    x Acme-MetaSyntactic-1.014/
    curl http://www.cpan.org/modules/by-authors/id/S/SB/SBURKE/Win32-Locale-0.04.tar.gz -R
      % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
				     Dload  Upload   Total   Spent    Left  Speed
    100  7598  100  7598    0     0  49572      0 --:--:-- --:--:-- --:--:-- 49660
    tar -x -v -f ~/.cpanx/Win32-Locale-0.04.tar.gz -C ~/.cpanx
    x Win32-Locale-0.04/
    /usr/bin/perl Makefile.PL
    Checking if your kit is complete...
    Looks good
    Generating a Unix-style Makefile
    Writing Makefile for Win32::Locale
    Writing MYMETA.yml and MYMETA.json

    Acme-MetaSyntactic 1.014 (not installed)
    Themed metasyntactic variables names
    By Philippe Bruhat (BooK) <book@cpan.org>
    Repository http://github.com/book/Acme-MetaSyntactic

    Dependencies:
    Carp 0 (have 1.29)
    Cwd 0 (have 3.40)
    ExtUtils::MakeMaker 0 (have 7.34)
    File::Basename 0 (have 2.84)
    File::Find 0 (have 1.23)
    File::Glob 0 (have 1.20_01)
    File::Spec 0 (have 3.40)
    File::Spec::Functions 0 (have 3.40)
    Getopt::Long 0 (have 2.49)
    IO::Handle 0 (have 1.34)
    IPC::Open3 0 (have 1.13)
    LWP::UserAgent 0 (have 6.15)
    List::Util 0 (have 1.50)
    Test::Builder::Module 0 (have 1.302136)
    Test::More 0 (have 1.302136)
    Win32::Locale 0 (not installed) *
	ExtUtils::MakeMaker 0 (have 7.34)
    base 0 (have 2.18)
    lib 0 (have 0.63)
    perl 5.006 (have 5.018002)
    strict 0 (have 1.07)
    warnings 0 (have 1.18)

    Install Order:
    Win32::Locale 0.04 (not installed)
    Acme::MetaSyntactic 1.014 (not installed)

    Do you want to install? [n]
    Not installing.

=head1 POSSIBLE ALTERNATIVE

If you don't want to install this module, you can use the existing cpan program to see what will actually be installed. Run "cpan" on the command line to enter its shell. Run "test Module", it will test the module and all it's dependencies, then run "is_tested", it will show the list of modules that will be installed. The format isn't as good as what would be shown by this program, but might be good enough.

=head1 METACPAN

L<https://metacpan.org/pod/App::Cpanx>

=head1 AUTHOR

Jacob Gelbman E<lt>gelbman@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2018 by Jacob Gelbman

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.18.2 or,
at your option, any later version of Perl 5 you may have available.

=cut

