Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist
View pause_cleanup.pl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
#!/usr/bin/env perl
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->{ $dni->version } ||= { values => [] };
push @{ $dist->{values} }, $file;
}
 
use YAML::XS;
use Sort::Versions qw(versioncmp);
 
$mech->form_number(1);
 
my %ticked;
 
for my $key (sort keys %found) {
my $dist = $found{ $key };
my @keep;
no warnings qw(uninitialized);
my @versions = reverse sort versioncmp keys %$dist;
push @keep, shift @versions while $versions[0] =~ /_/; # keep new trial versions
push @keep, shift @versions if @versions; # keep latest stable
if (my @legacy = grep !/_/, @versions) { # if there exist any legacy versions
push @keep, $legacy[0]; # ... keep the latest one
@versions = grep { $_ ne $legacy[0] } @versions;
}
for my $keeper (@keep) {
print "keeping $key $keeper\n";
}
for my $version (@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;
Owner

FYI, it assumes that trial releases are those where the version number includes an underscore. The "-TRIAL" convention is not honoured.

Thanks, works great

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.