pause_cleanup.pl

#!/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;

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

Thanks, works great