pm-uninstall

#!perl

use strict;
use warnings;
use File::Spec;
use Getopt::Long qw/GetOptions/;
use Pod::Usage qw/pod2usage/;
use Config;
use ExtUtils::MakeMaker;
use LWP::Simple;
use YAML;
use CPAN::DistnameInfo;

my $base_url = 'http://deps.cpantesters.org/depended-on-by.pl?dist=';
my $cpanmetadb = 'http://cpanmetadb.appspot.com/v1.0/package';

our $VERSION = "0.03";

my $opt = +{};
GetOptions(
    'f|force'     => \$opt->{force},
    'v|verbose!'  => \$opt->{verbose},
    'c|checkdeps' => \$opt->{check_deps},
    'h|help!'     => \$opt->{help},
);

pod2usage 1 if $opt->{help} or !@ARGV;

main(@ARGV);
exit;

sub main {
    my @modules = @_;
    for my $module (@modules) {
        my($packlist, $dist, $vname) = find_packlist($module);
        unless ($packlist) {
            warn "Module $module not installed\n";
            next;
        }

        if ($opt->{force} or ask_permission($module, $dist, $vname, $packlist)) {
            uninstall_from_packlist($packlist);
            warn "Module $module successfully uninstalled.\n";
        }
    }
}

sub vname_for {
    my $module = shift;

    my $yaml = get("$cpanmetadb/$module") or return;
    my $meta = YAML::Load($yaml);
    my $info = CPAN::DistnameInfo->new($meta->{distfile}) or return;

    return $info->distvname;
}

sub ask_permission {
    my($module, $dist, $vname, $packlist) = @_;

    my(@deps, %seen);
    if ($opt->{check_deps}) {
        $vname = vname_for($module);
        warn "Checking modules depending on $vname\n" if $opt->{verbose};
        my $content = get("$base_url$vname");
        for my $dep ($content =~ m|<th align=left>([^<]+)</th>|smg) {
            $dep =~ s/\-[^\-]+$//; # version
            next if $seen{$dep}++;
            push @deps, $dep if locate_pack($dep);
        }
    }

    warn "$module is included in the distribution $dist and contains:\n\n";

    open my $in, "<", $packlist or die "$packlist: $!";
    while (<$in>) {
        warn "  $_";
    }
    warn "\n";

    my $default = 'y';
    if (@deps) {
        warn "Also, they're depended on by the following dists you have:\n\n";
        for my $dep (@deps) {
            warn "  $dep\n";
        }
        warn "\n";
        $default = 'n';
    }

    lc(prompt("Are you sure to uninstall $dist?", $default)) eq 'y';
}

sub find_packlist {
    my $module = shift;

    warn "Finding $module in your \@INC\n" if $opt->{verbose};

    # find with the given name first
    (my $try_dist = $module) =~ s!::!-!g;
    my $pl = locate_pack($try_dist);
    return ($pl, $try_dist) if $pl;

    warn "Looking up $module on cpanmetadb\n" if $opt->{verbose};

    # map module -> dist and retry
    my $yaml = get("$cpanmetadb/$module") or return;
    my $meta = YAML::Load($yaml);
    my $info = CPAN::DistnameInfo->new($meta->{distfile});

    my $pl2 = locate_pack($info->dist);
    return ($pl2, $info->dist, $info->distvname) if $pl2;

    return;
}

sub locate_pack {
    my $dist = shift;
    $dist =~ s!-!/!g;

    for my $lib (@INC) {
        my $packlist = "$lib/auto/$dist/.packlist";
        return $packlist if -f $packlist && -r _;
    }

    return;
}

sub uninstall_from_packlist {
    my $packlist = shift;

    open my $fh, '<', $packlist or die "$packlist: $!";
    while (<$fh>) {
        chomp;
        print -f $_ ? 'unlink   ' : 'not found', " : $_\n" if $opt->{verbose};
        unlink $_ or warn "$_: $!\n";
    }
    close $fh;

    unlink $packlist;
}

__END__

=head1 NAME

  pm-uninstall - Uninstall modules

=head1 SYNOPSIS

  pm-uninstall [options] Module ...

  options:
      -v,--verbose    Turns on chatty output
      -f,--force      Uninstalls without prompts
      -c,--checkdeps  Check dependencies
      -h,--help       This help message