Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
128 lines (97 sloc) 2.97 KB
#!/usr/local/bin/perl
# This code works for 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 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
use 5.010;
use strict;
use warnings;
use lib 'lib';
use Carp;
use CPAN::DistnameInfo;
use File::Spec;
use WWW::Mechanize;
my $home = $ENV{HOME} || '.';
my $rc = File::Spec->catfile($home, '.pause');
# Process .pause
open my $pauserc, '<', $rc or die "can't open $rc for reading: $!";
my %arg;
while (<$pauserc>) {
chomp;
next unless $_ and $_ !~ /^\s*#/;
my ($k, $v) = /^\s*(\w+)\s+(.+)$/;
croak "multiple enties for $k" if $arg{$k};
$arg{$k} = $v;
}
if (@ARGV) {
die "usage: tl\n or: tl USER PASS\n" unless @ARGV == 2;
@arg{ qw(user password) } = @ARGV;
}
my $username = $arg{user};
die "couldn't get username" unless length $username;
die "no password found" unless $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 unknown path type: $path";
next FILE;
}
}
next if $dni->dist eq 'perl';
my $by_name = $found{ $dni->dist } ||= {};
my $dist = $by_name->{ eval $dni->version } ||= { values => [] };
push @{ $dist->{values} }, $file;
}
use YAML::XS;
$mech->form_number(1);
my %ticked;
for my $key (sort keys %found) {
my $dist = $found{ $key };
next unless keys %$dist > 3;
my @versions = sort { $b <=> $a } keys %$dist;
for my $version (map { $versions[$_] } 3 .. $#versions) {
for my $file (@{ $dist->{ $version }{values} }) {
print "scheduling $file for deletion\n";
$ticked{ $file } ++;
}
}
}
print "ticked ", scalar keys %ticked, " tickey boxes\n";
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');
# print $mech->content;