Skip to content

@tobyink /pause_cleanup.pl
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
#!/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;
@tobyink
Owner

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

@battlemidget

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.