view release on metacpan or  search on metacpan

lib/App/pmuninstall.pm  view on Meta::CPAN

        $self->{meta} = $install_json;
        last;
    }
    return $name;
}

sub locate_pack {
    my ($self, $dist) = @_;
    $dist =~ s!-!/!g;
    for my $lib (@{$self->{inc}}) {
        my $packlist = "$lib/auto/$dist/.packlist";
        $self->puts("-> Finding .packlist $packlist") if $self->{verbose} > 1;
        return $packlist if -f $packlist && -r _;
    }
    return;
}

sub is_core_module {
    my ($self, $dist, $packlist) = @_;
    require Module::CoreList;
    return unless exists $Module::CoreList::version{$perl_version}{$dist};
    return 1 unless $packlist;

    my $is_core = 0;
    for my $dir (@core_modules_dir) {
        my $safe_dir = quotemeta $dir; # workaround for MSWin32
        if ($packlist =~ /^$safe_dir/) {
            $is_core = 1;
            last;
        }
    }
    return $is_core;
}

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

    my @deps = $self->find_deps($vname, $module);

    $self->puts if $self->{verbose};
    $self->puts("$module is included in the distribution $dist and contains:\n")
        unless $self->{quiet};
    for my $file ($self->fixup_packlist($packlist)) {
        chomp $file;
        $self->puts("  $file") unless $self->{quiet};
    }
    $self->puts unless $self->{quiet};

    return 'force uninstall' if $self->{force};

    my $default = 'y';
    if (@deps) {
        $self->puts("Also, they're depended on by the following installed dists:\n");
        for my $dep (@deps) {
            $self->puts("  $dep");
        }
        $self->puts;
        $default = 'n';
    }

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

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

    return unless $self->{check_deps} && !$self->{force};
    $vname ||= $self->vname_for($module) or return;

    $self->puts("Checking modules depending on $vname") if $self->{verbose};
    my $content = $self->fetch("$depended_on_by$vname") or return;

    my (@deps, %seen);
    for my $dep ($content =~ m|<li><a href=[^>]+>([a-zA-Z0-9_:-]+)|smg) {
        $dep =~ s/^\s+|\s+$//smg; # trim
        next if $seen{$dep}++;
        local $OUTPUT_INDENT_LEVEL = $OUTPUT_INDENT_LEVEL + 1;
        $self->puts("Finding $dep in your \@INC (dependencies)") if $self->{verbose};
        push @deps, $dep if $self->locate_pack($dep);
    }

    return @deps;
}

sub prompt {
    my ($self, $msg, $default) = @_;
    require ExtUtils::MakeMaker;
    ExtUtils::MakeMaker::prompt($msg, $default);
}

sub fixup_packlist {
    my ($self, $packlist) = @_;
    my @target_list;
    my $is_local_lib = $self->is_local_lib($packlist);
    my $plist = ExtUtils::Packlist->new($packlist);
    while (my $file = each %$plist) {
        if ($is_local_lib) {
            next unless $self->is_local_lib($file);
        }
        push @target_list, $file;
    }
    return @target_list;
}

# NOTE only use this for comparing paths
sub _canon_path_compare {
    my ($self, $path) = @_;
    $path = Cwd::realpath($path);
    if( $^O eq 'MSWin32' ) {
        require Win32;
        $path = Win32::GetLongPathName($path);
    }

    return $path;
}

sub is_local_lib {
    my ($self, $file) = @_;
    return unless $self->{local_lib};

    my $local_lib_base = quotemeta $self->_canon_path_compare($self->{local_lib});
    $file = $self->_canon_path_compare($file);

    return $file =~ /^$local_lib_base(?:\/|\z)/ ? 1 : 0;
}

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

    $self->puts("Fetching $module vname on cpanmetadb") if $self->{verbose};
    my $yaml = $self->fetch("$cpanmetadb/$module") or return;
    my $meta = YAML::Load($yaml);
    my $info = CPAN::DistnameInfo->new($meta->{distfile}) or return;

    return $info->distvname;
}

# taken from cpan-outdated
sub setup_local_lib {
    my $self = shift;
    return unless $self->{local_lib};

    unless (-d $self->{local_lib}) {
        $self->puts(colored ['red'], "! $self->{local_lib} : no such directory");
        exit 1;
    }

    local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
    $self->{inc} = [
        grep { defined }
        map { Cwd::realpath($_) }
            @{$self->build_active_perl5lib($self->{local_lib}, $self->{self_contained})}
    ];
    push @{$self->{inc}}, @INC unless $self->{self_contained};
}

sub build_active_perl5lib {
    my ($self, $path, $interpolate) = @_;
    my $perl5libs = [
        $self->install_base_arch_path($path),
        $self->install_base_perl_path($path),
        $interpolate && $ENV{PERL5LIB} ? split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB}) : (),
    ];
    return $perl5libs;
}

sub install_base_perl_path {
    my ($self, $path) = @_;
    File::Spec->catdir($path, 'lib', 'perl5');
}

sub install_base_arch_path {
    my ($self, $path) = @_;
    File::Spec->catdir($self->install_base_perl_path($path), $Config{archname});
}

sub fetch {
    my ($self, $url) = @_;
    $self->puts("-> Fetching from $url") if $self->{verbose};
    my $res = HTTP::Tiny->new->get($url);
    return if $res->{status} == 404;
    die "[$res->{status}] fetch $url failed!!\n" if !$res->{success};
    return $res->{content};
}

sub slurp {
    my ($self, $file) = @_;
    open my $fh, '<', $file or die "$file $!";
    do { local $/; <$fh> };
}

sub puts {
    my ($self, @msg) = @_;
    push @msg, '' unless @msg;
    print '  ' x $OUTPUT_INDENT_LEVEL if $OUTPUT_INDENT_LEVEL;
    print @msg, "\n";
}

sub usage {
    my $self = shift;
    $self->puts(<< 'USAGE');
Usage:
      pm-uninstall [options] Module [...]

      options:
          -v,--verbose                  Turns on chatty output
          -f,--force                    Uninstalls without prompts
          -c,--checkdeps                Check dependencies (defaults to on)
          -n,--no-checkdeps             Don't check dependencies
          -q,--quiet                    Suppress some messages
          -h,--help                     This help message
          -V,--version                  Show version
          -l,--local-lib                Additional module path
          -L,--local-lib-contained      Additional module path (don't include non-core modules)
USAGE

    exit 1;
}

sub short_usage {
    my $self = shift;
    $self->puts(<< 'USAGE');
Usage: pm-uninstall [options] Module [...]

Try `pm-uninstall --help` or `man pm-uninstall` for more options.
USAGE

    exit 1;
}

sub prepare_include_paths {
    my ($class, $inc) = @_;
    my $new_inc = [];
    my $archname = quotemeta $Config{archname};
    for my $path (@$inc) {
        push @$new_inc, $path;
        next if $path eq '.' or $path =~ /$archname/;
        push @$new_inc, File::Spec->catdir($path, $Config{archname});
    }
    return [do { my %h; grep !$h{$_}++, @$new_inc }];
}

1;
__END__

=head1 NAME

App::pmuninstall - Uninstall modules

=head1 DESCRIPTION

App::pmuninstall is a fast module uninstaller.
delete files from B<.packlist>.

L<App::cpanminus> and, L<App::cpanoutdated> with a high affinity.

=head1 SYNOPSIS

uninstall MODULE

  $ pm-uninstall App::pmuninstall

=head1 OPTIONS

=over

=item -f, --force

Uninstalls without prompts

  $ pm-uninstall -f App::pmuninstall

=item -v, --verbose

Turns on chatty output

  $ pm-uninstall -v App::cpnaminus

=item -c, --checkdeps

Check dependencies ( default on )

  $ pm-uninstall -c Plack

=item -n, --no-checkdeps

Don't check dependencies

  $ pm-uninstall -n LWP

=item -q, --quiet

Suppress some messages

  $ pm-uninstall -q Furl

=item -h, --help

Show help message

  $ pm-uninstall -h

=item -V, --version

Show version

  $ pm-uninstall -V

=item -l, --local-lib

Additional module path

  $ pm-uninstall -l extlib App::pmuninstall

=item -L, --local-lib-contained

Additional module path (don't include non-core modules)

  $ pm-uninstall -L extlib App::pmuninstall

=back

=head1 AUTHOR

Yuji Shimada

Tatsuhiko Miyagawa

=head1 SEE ALSO