Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
#!/usr/bin/env perl
# This code works for dagolden, based on a program originally by rjbs. It
# might not work for you. You are hereby empowered to do anything you want
# with this code, including fixing its bugs and redistributing it with your
# own license and API and whatever you want. It'd be nice if you mentioned
# dagolden and rjbs in your fork, but if you don't want to, that's just fine.
#
# The only thing you can't do is act like there's some guarantee that this
# code will actually work or even refrain from blowing stuff up. You're on
# your own. -- rjbs, 2014-04-23 and dagolden, 2016-07-06
use 5.014;
use strict;
use warnings;
use Carp;
use CPAN::DistnameInfo;
use WWW::Mechanize;
use IO::Prompt::Tiny qw/prompt/;
my %arg;
if (@ARGV) {
die "usage: $0\n or: $0 USER PASS\n" unless @ARGV == 2;
@arg{qw(user password)} = @ARGV;
}
$arg{user} //= prompt("username: ");
$arg{password} //= prompt("password: ");
$arg{user} = uc $arg{user};
my $username = $arg{user};
die "no username given" unless length $username;
die "no password given" unless length $arg{password};
my $mech = WWW::Mechanize->new;
$mech->credentials( $username, $arg{password} );
my $res =
$mech->get(q{https://pause.perl.org/pause/authenquery?ACTION=delete_files});
my @files = grep { defined }
map { $_->possible_values }
grep { $_->type eq 'checkbox' } $mech->form_number(1)->inputs;
my %found;
FILE: for my $file (@files) {
next FILE if $file eq 'CHECKSUMS';
my $path = sprintf "authors/id/%s/%s/%s/%s",
substr( $username, 0, 1 ),
substr( $username, 0, 2 ),
$username,
$file;
my $dni;
if ( $file =~ m{\.(readme|meta)\z} ) {
my $ext = $1;
( my $fake = $path ) =~ s{\.$1\z}{.tar.gz};
$dni = CPAN::DistnameInfo->new($fake);
}
else {
$dni = CPAN::DistnameInfo->new($path);
unless ( defined $dni->extension ) {
warn "ignoring path with unknown extension: $path\n";
next FILE;
}
}
next if $dni->dist eq 'perl';
my $by_name = $found{ $dni->dist } ||= {};
my $version = $dni->version;
die "No version found" unless length $version;
$version =~ s/-TRIAL.*//;
$version =~ s/_//g;
die "No version parsed for " . $dni->pathname . " with version " . $dni->version
unless eval { version->new($version); 1 };
my $dist = $by_name->{$version} ||= { values => [] };
push @{ $dist->{values} }, $file;
$by_name->{$version}{is_trial} = ( $dni->version =~ /_|TRIAL/ ? 1 : 0 );
}
$mech->form_number(1);
my %ticked;
for my $key ( sort keys %found ) {
my $dist = $found{$key};
my $count = 0;
my @versions = map { $_->[1] }
sort { $b->[0] <=> $a->[0] }
map { [ version->new($_), $_ ] }
keys %$dist;
for my $version (@versions) {
my $is_trial = $dist->{$version}{is_trial};
# skip active TRIAL releases
if ( $count == 0 && $is_trial ) {
next;
}
# skip up to 3 stable releases
if ( $count < 3 && !$is_trial ) {
$count++;
next;
}
# delete everything else
for my $file ( @{ $dist->{$version}{values} } ) {
say "scheduling $file for deletion";
$ticked{$file}++;
$dist->{$version}{delete} = 1;
}
}
}
say "Going to delete ", scalar keys %ticked, " files.";
my $ok = prompt( "Go ahead and delete them (y/n)?", "n" );
if ( $ok !~ /^y(?:es)?$/ ) {
say "Aborting!";
exit 1;
}
for my $input ( $mech->find_all_inputs( name => 'pause99_delete_files_FILE' ) ) {
for my $val ( $input->possible_values ) {
next if !defined $val || !$ticked{$val};
$input->value($val);
last;
}
}
$mech->click('SUBMIT_pause99_delete_files_delete');
say "Done!";
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment