bin/analysis-oldreports-extinction-program.pl

   1 #!/home/andreas/src/installed-perls/v5.16.0/4e6d/bin/perl
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9
  10
  11 =head1 SYNOPSIS
  12
  13
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my $optpod = <<'=back';
  22
  23 =item B<--focus=s> Default: tar
  24
  25 Valid values: C<tar> or C<dir>. RTFS.
  26
  27 =item B<--help|h!>
  28
  29 This help
  30
  31 =item B<--keepresults=i> Default: 4
  32
  33 Number of result-directories or result-tarballs to never delete.
  34
  35 =item B<--minage=f> Default: 690
  36
  37 Minimum age in days of the target directory
  38 (measured with C<-M>).
  39
  40 =item B<--noninteractive|noni>
  41
  42 Don't ask, just apply the default answer.
  43
  44 =item B<--untildf=i> Default: 48000000
  45
  46 Run extinction until available blocks reported
  47 by df is above this value.
  48
  49 =item B<--yes|y!>
  50
  51 The interactive question is normally answered with no as the default.
  52 With --yes the default becomes yes.
  53
  54 =back
  55
  56 =head1 DESCRIPTION
  57
  58 What we look for is an old and big and outdated directory. For the
  59 arbitrary current thresholds RTFS. When we have listed one, we exit.
  60 We show it with age, size and neighbors of the same Distname.
  61
  62 =head1 BUGS
  63
  64 The files in C<workdir/solved/> are removed too (which is good) but
  65 they were not removed before 2016-03-31, so we should bulk remove the
  66 left overs separately some day; this affects files like the output of:
  67
  68   ls -lt /home/andreas/data/cnntp-solver-2009/workdir/solved/Any-Moose-0.*
  69   ls -lt /home/andreas/data/cnntp-solver-2009/workdir/solved/package-watchdog-*
  70
  71 Note that package-watchdog-0.07.slv is the oldest(2009) and
  72 package-watchdog-0.04.yml is the newest (2013). Why? Because the
  73 package has ceased to exist.
  74
  75 =cut
  76
  77
  78 use FindBin;
  79 use lib "$FindBin::Bin/../lib";
  80 BEGIN {
  81     push @INC, qw(       );
  82 }
  83
  84 use Dumpvalue;
  85 use File::Basename qw(dirname);
  86 use File::Path qw(mkpath rmtree);
  87 use File::Spec;
  88 use File::Temp;
  89 use Getopt::Long;
  90 use Pod::Usage;
  91 use Hash::Util qw(lock_keys);
  92 use Redis 1.967;
  93 sub myredis () {
  94     my $redis = Redis->new(reconnect => 120, every => 1000);
  95 }
  96
  97 use LWP::UserAgent;
  98 use JSON::XS;
  99 use CPAN::DistnameInfo;
 100 use List::AllUtils qw(reduce);
 101 use CPAN::Version;
 102 use FindBin;
 103 use lib "$FindBin::Bin/../CPAN-Blame/lib";
 104 use CPAN::Blame::Config::Cnntp;
 105 use CPAN::DistnameInfo;
 106 use Term::Prompt qw(prompt);
 107 use YAML::XS;
 108 use Filesys::Df qw(df);
 109 use Time::HiRes qw(sleep);
 110
 111 my $ua = LWP::UserAgent->new();
 112 $ua->default_header("Accept-Encoding", "gzip");
 113 my $jsonxs = JSON::XS->new->indent(0);
 114
 115 my @opt = $optpod =~ /B<--(\S+)>/g;
 116 our %Opt;
 117 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
 118 GetOptions(\%Opt,
 119            @opt,
 120           ) or pod2usage(1);
 121 if ($Opt{help}) {
 122     pod2usage(0);
 123 }
 124 for my $opt (qw(focus untildf minage keepresults)) {
 125     next if defined $Opt{$opt};
 126  LINE: for my $line (split /\n/, $optpod) {
 127         if ($line =~ /--\Q$opt\E=.+?Default: (.+)/) {
 128             $Opt{$opt} = $1;
 129             last LINE;
 130         }
 131     }
 132 }
 133
 134 sub show_df (){
 135     my $df = df '/';
 136     warn "df bavail: $df->{bavail}\n";
 137     $df->{bavail};
 138 }
 139
 140 sub rm_other ($) {
 141     my($distv) = @_;
 142     for my $ext (qw(slv.LCK yml slvdv.gz slv slvdv)) {
 143         my $workdirfile = "/home/andreas/data/cnntp-solver-2009/workdir/solved/$distv.$ext";
 144         if (-e $workdirfile) {
 145             warn "Deleting $workdirfile\n";
 146             unlink $workdirfile or die "Could not unlink '$workdirfile': $!";
 147         }
 148     }
 149     for my $zs (qw(analysis:distv:calctimestamp)) {
 150         warn "zrem-redis: redis-cli zrem $zs $distv\n";
 151         my $redis = myredis;
 152         $redis->zrem($zs, $distv);
 153     }
 154     warn "Done.\n";
 155 }
 156 sub treat_dir ($$$$) {
 157     my($parent, $distv, $dist, $v) = @_;
 158     my $query = sprintf "http://fastapi.metacpan.org/v1/release/_search?q=distribution:%s&fields=name,date,status,version,author&size=400", $dist;
 159     sleep 0.2;
 160     my $resp = $ua->get($query);
 161     # print $query;
 162     my $jsontxt = $resp->decoded_content;
 163     my $j = eval { $jsonxs->decode($jsontxt); };
 164     return if ! $j or $@;
 165     my $hits = $j->{hits}{hits};
 166     my($releasedate) = map { $_->{fields}{date} } grep { $_->{fields}{name} eq $distv } @$hits;
 167     unless ($releasedate) {
 168         warn "Did not find own releasedate for $distv";
 169         return;
 170     }
 171     my $cpanversion = reduce {
 172         CPAN::Version->vgt($a,$b) ? $a : $b
 173         } map { $_->{fields}{version} } grep { $_->{fields}{date} ge $releasedate } @$hits;
 174     if (CPAN::Version->vgt($cpanversion, $v)) {
 175         my $default_answer = $Opt{yes} ? "y" : "n";
 176         my $answer;
 177         if ($Opt{noninteractive}) {
 178             $answer = $default_answer;
 179         } else {
 180             $answer = lc prompt "x",
 181                 "Shall I delete $distv (cpanversion=$cpanversion) and related workdir files? (y/n)", "", 'y';
 182         }
 183         if ($answer eq "y") {
 184             rmtree "$parent/$distv";
 185             rm_other $distv;
 186         }
 187     }
 188 }
 189
 190 my $root = $CPAN::Blame::Config::Cnntp::Config->{ctgetreports_dir};
 191 my $bavail = show_df;
 192 my $outer_purged_something = 0;
 193 LOOP: while ($bavail < $Opt{untildf}) {
 194     my $purged_something = 0;
 195     opendir my $dh, $root or die "Could not open '$root': $!";
 196  OUTER: for my $letter (readdir $dh) {
 197         next unless $letter =~ /^[A-Za-z]$/;
 198         opendir my $dh2, "$root/$letter" or die "Could not open '$root/$letter': $!";
 199         my %odist;
 200     INNER: for my $distdir (readdir $dh2) {
 201             next if $distdir eq "." or $distdir eq "..";
 202             my $tdir_or_tar = "$root/$letter/$distdir";
 203             my($distv, $isdir, $want_treat_dir);
 204             if (0) {
 205             } elsif (-d $tdir_or_tar) {
 206                 warn "looking at directory $tdir_or_tar";
 207                 if ($Opt{focus} eq "tar") {
 208                     next INNER;
 209                 } elsif ($Opt{focus} eq "dir") {
 210                     if (-f "$tdir_or_tar.tar") {
 211                         warn "skipping $tdir_or_tar because tarball also found";
 212                         next INNER;
 213                     }
 214                     $want_treat_dir = 1;
 215                 } else {
 216                     die "Illegal focus '$Opt{focus}'";
 217                 }
 218                 $distv = $distdir;
 219                 $isdir = 1;
 220             } elsif ($distdir =~ /(.+)\.tar$/) {
 221                 $distv = $1;
 222                 $isdir = 0;
 223             } else {
 224                 # ignore me for now
 225                 next INNER;
 226             }
 227             my $d = CPAN::DistnameInfo->new("FOO/$distv.tgz");
 228             my $dist = $d->dist;
 229             my $v = $d->version;
 230             if ($want_treat_dir) {
 231                 treat_dir("$root/$letter", $distdir, $dist, $v);
 232                 $bavail = show_df;
 233                 sleep 1;
 234                 next INNER;
 235             }
 236             my $a = $odist{$dist}{$distv} ||= [];
 237             my $i = @$a;
 238             push @$a,
 239                 {
 240                  abs => $tdir_or_tar,
 241                  isdir => $isdir,
 242                  M => -M $tdir_or_tar,
 243                  dist => $dist,
 244                  distv => $distv,
 245                  v => $v,
 246                  i => $i,
 247                 };
 248         }
 249         for my $d (sort {scalar keys %{$odist{$b}} <=> scalar keys %{$odist{$a}}} keys %odist) {
 250             my $l = $odist{$d};
 251             next unless scalar keys %$l > $Opt{keepresults};
 252
 253             my $oldest = reduce { $a > $b ? $a : $b } map { $_->{M} } map { @{$l->{$_}} } keys %$l;
 254             next unless $oldest >= $Opt{minage};
 255
 256             my($abs_of_oldest);
 257         DISTV: for my $distv (keys %$l) {
 258                 for my $i (0..$#{$l->{$distv}}) {
 259                     if ($l->{$distv}[$i]{M} == $oldest) {
 260                         $abs_of_oldest = $l->{$distv}[$i]{abs};
 261                         last DISTV;
 262                     }
 263                 }
 264             }
 265             open my $duh, "-|", du => "-s", $abs_of_oldest or die "Could not fork for 'du -s $abs_of_oldest': $!";
 266             my($duline) = <$duh>;
 267             my($du_of_oldest) = split " ", $duline;
 268
 269             # next unless $du_of_oldest > 7000; # arbitrary
 270             my $ll = []; # = [ map { @{$l->{$_}} } sort { $l->{$b}->{M} <=> $l->{$a}->{M} } keys %$l ];
 271             for my $distv (keys %$l) {
 272                 for my $i (0..$#{$l->{$distv}}) {
 273                     push @$ll, $l->{$distv}[$i];
 274                 }
 275             }
 276             my $lll = [ sort { $b->{M} <=> $a->{M} } @$ll ];
 277             $lll->[0]{du} = $du_of_oldest;
 278             print YAML::XS::Dump $lll;
 279             my $default_answer = $Opt{yes} ? "y" : "n";
 280             my $answer;
 281             if ($Opt{noninteractive}) {
 282                 $answer = $default_answer;
 283             } else {
 284                 $answer = lc prompt "x",
 285                     "Shall I delete $lll->[0]{abs} (Mtime=$lll->[0]{M}) and related workdir files? (y/n)", "", $default_answer;
 286             }
 287             if ($answer eq "y") {
 288                 warn "Deleting $lll->[0]{abs}\n";
 289                 rmtree $lll->[0]{abs};
 290                 my $distv = $lll->[0]{distv};
 291                 rm_other($distv);
 292                 warn "Done.\n";
 293                 $purged_something = 1;
 294                 $outer_purged_something = 1;
 295             } else {
 296                 warn "Nothing deleted\n";
 297             }
 298             last OUTER;
 299         }
 300     }
 301     $bavail = show_df;
 302     unless ($purged_something) {
 303         my $else = $outer_purged_something ? " else" : "";
 304         die "Nothing$else found to delete, giving up";
 305     }
 306     sleep 1;
 307 }
 308
 309 # Local Variables:
 310 # mode: cperl
 311 # cperl-indent-level: 4
 312 # End: