Create a gist now

Instantly share code, notes, and snippets.

#!/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
tobyink commented Apr 23, 2014

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