bin/beforemaintrelease.pl

   1 #!/usr/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 $0 [OPTIONS]
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--help|h!>
  24
  25 This help
  26
  27 =item B<--minpostdate=i>
  28
  29 Looks like an integer but stands for a month in the format YYYYMM.
  30 Actual DB range is 199908 to, at the time of this writing, 202202.
  31 Used to generate where clauses such as
  32
  33    ... where postdate >= $dbh->quote($Opt{minpostdate}) ...
  34
  35 Defaults to 201607.
  36
  37 =item B<--newperl=s@>
  38
  39 C<5.20.0 RC1>
  40
  41 =item B<--oldperl=s@>
  42
  43 C<5.18.2>
  44
  45
  46
  47 =back
  48
  49 =head1 DESCRIPTION
  50
  51 We generate a json file and a txt file. The latter for myself to view
  52 the upcoming contents easily, the json for the webserver.
  53
  54 The generation took about 1-2 hours in the beginning but it got slower
  55 and slower, the more reports arrived.
  56
  57 =head1 HISTORY
  58
  59 formerly known as cron-comparing-5181-5182rc2.pl
  60
  61 =head1 DEPLOYMENT
  62
  63 There were some rather long lines in the crontab that had to be edited
  64 whenever a new release appeared. Something like
  65
  66 58 17 28 * * /home/andreas/src/installed-perls/v5.16.0/4e6d/bin/perl /home/andreas/src/andk-cpan-tools/bin/beforemaintrelease.pl --newperl="5.27.4" --oldperl=5.26.0 > /home/andreas/beforemaintrelease-cron.out 2>&1
  67
  68 Having more than one pair of old and new perl was allowed. Running
  69 them every few days was also usual
  70
  71 =cut
  72
  73
  74 use FindBin;
  75 use lib "$FindBin::Bin/../lib";
  76 BEGIN {
  77     push @INC, qw(       );
  78 }
  79
  80 use Dumpvalue;
  81 use File::Basename qw(dirname);
  82 use File::Path qw(mkpath);
  83 use File::Spec;
  84 use File::Temp;
  85 use Getopt::Long;
  86 use Pod::Usage;
  87 use POSIX ();
  88 use Hash::Util qw(lock_keys);
  89
  90 our %Opt;
  91 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
  92 GetOptions(\%Opt,
  93            @opt,
  94           ) or pod2usage(1);
  95 if ($Opt{help}) {
  96     pod2usage(0);
  97 }
  98 $Opt{oldperl} = ['5.18.2']     unless $Opt{oldperl} && @{$Opt{oldperl}};
  99 $Opt{newperl} = ['5.20.0 RC1'] unless $Opt{newperl} && @{$Opt{newperl}};
 100 $Opt{minpostdate} = '201607';
 101 die "the arrayrefs for oldperl and newperl must be of same length, "
 102     . "found lengths %d and %d, cannot continue",
 103     scalar @{$Opt{oldperl}},
 104     scalar @{$Opt{newperl}}
 105     unless scalar @{$Opt{oldperl}}==scalar @{$Opt{newperl}};
 106
 107 use FindBin;
 108 use lib "$FindBin::Bin/../CPAN-Blame/lib";
 109 use CPAN::Blame::Config::Cnntp;
 110
 111 my $HAVE_IPCCL = eval { require IPC::ConcurrencyLimit; 1 };
 112 die unless $HAVE_IPCCL;
 113
 114 use DBI;
 115
 116 my($workdir);
 117 BEGIN {
 118     $workdir = File::Spec->catdir
 119         ($CPAN::Blame::Config::Cnntp::Config->{solver_vardir},
 120          "workdir");
 121 }
 122 my($basename) = File::Basename::basename(__FILE__);
 123 my $limit = IPC::ConcurrencyLimit->new
 124     (
 125      max_procs => 1,
 126      path      => "$workdir/IPC-ConcurrencyLimit-$basename",
 127     );
 128 my $limitid = $limit->get_lock;
 129 if (not $limitid) {
 130     warn "Another process appears to be still running. Exiting.";
 131     exit(0);
 132 }
 133
 134 my $pgdbh = DBI->connect("dbi:Pg:dbname=analysis") or die "Could not connect to 'analysis': $DBI::err";
 135 my $sth0 = $pgdbh->prepare("SELECT COUNT(*) FROM cpanstats WHERE postdate >= ? and perl = ?");
 136 #### my $sth2 = $pgdbh->prepare("select perl, state, count(*) from cpanstats where postdate >= ? and dist = ? and version = ? and perl in (?, ?) and state in ('pass','fail') group by perl, state");
 137 my $sth3 = $pgdbh->prepare("SELECT COUNT(distinct(dist||version)) FROM cpanstats WHERE postdate >= ? and perl = ?");
 138 use JSON::XS;
 139 my $jsonxs = JSON::XS->new->indent(1)->canonical(1);
 140
 141 for my $i (0..$#{$Opt{newperl}}) {
 142     my($perl1,$perl2);
 143     $perl1 = $Opt{oldperl}[$i];
 144     $perl2 = $Opt{newperl}[$i];
 145     unless ($perl1 && $perl2) {
 146         die "options oldperl and newperl are mandatory, found $perl1 vs $perl2";
 147     }
 148     $sth0->execute($Opt{minpostdate}, $perl2);
 149     my($total) = $sth0->fetchrow_array;
 150     $sth3->execute($Opt{minpostdate}, $perl2);
 151     # mnemotechnics: newperl and perl2 and rc all associated with the release candidate
 152     my($totalrcdists) = $sth3->fetchrow_array;
 153
 154     # on the days 2016062[12] the smoker was of DCOLLINS was broken
 155
 156     # update 2022-02-09: ad-hoc decision: ignore all tests before 201607 (abandon 70M)
 157
 158     $pgdbh->do("CREATE temporary TABLE distnames$i AS
 159  ( SELECT DISTINCT dist, version FROM cpanstats
 160              WHERE postdate >= ?
 161                AND state = 'fail'
 162                AND perl = ?
 163  ) ", undef, $Opt{minpostdate}, $perl2) or die;
 164     my $sth1 = $pgdbh->prepare("select dist, version from distnames$i");
 165
 166     my $ts = POSIX::strftime "%FT%T", gmtime(time);
 167     my $S =
 168         {
 169          "!ALL" => {
 170                     perls        => [ $perl1, $perl2 ],
 171                     $perl2       => $total,
 172                     totalrcdists => $totalrcdists,
 173                     datetime     => $ts,
 174                    },
 175         };
 176     #### warn "starting matrix at $ts";
 177     $pgdbh->do("CREATE temporary TABLE matrix$i AS
 178   ( SELECT perl, state, cpanstats.dist, cpanstats.version, count(*) cnt
 179     FROM cpanstats
 180     JOIN distnames$i ON (distnames$i.dist=cpanstats.dist AND distnames$i.version=cpanstats.version)
 181     WHERE postdate >= '$Opt{minpostdate}' and perl in ('$perl1', '$perl2') and state in ('pass','fail')
 182     GROUP BY perl, state, cpanstats.dist, cpanstats.version
 183   )") or die "error while creating temporary table 2: $DBI::err";
 184     my $ts2 = POSIX::strftime "%FT%T", gmtime(time);
 185     #### warn "finished matrix at $ts2";
 186     my $sth5 = $pgdbh->prepare("SELECT matrix$i.perl, matrix$i.state, matrix$i.cnt from matrix$i WHERE matrix$i.dist=? and matrix$i.version=?");
 187
 188  MAIN: {
 189         $sth1->execute;
 190         my $i = 0;
 191         my $rows = $sth1->rows;
 192
 193         while (my($dist,$version) = $sth1->fetchrow_array) {
 194             $i++;
 195             #### $sth2->execute($Opt{minpostdate}, $dist, $version, $perl1, $perl2);
 196             #### $DB::single = $dist eq "Lingua-Ogmios" && $version eq '0.011';
 197             $sth5->execute($dist, $version);
 198             my $s;
 199             my %seen = (pass => 0, fail => 0);
 200             #### while (my($perl,$state,$count) = $sth2->fetchrow_array) {
 201             while (my($perl,$state,$count) = $sth5->fetchrow_array) {
 202                 $s->{$perl}{$state} = $count;
 203                 $seen{$state}++;
 204             }
 205             my $ignore = 0;
 206             if ($seen{pass} == 0) {
 207                 $ignore=1;
 208             }
 209             if ($seen{fail} == 2 and $seen{pass} == 2) {
 210                 $ignore=1;
 211             }
 212             store($dist,$version,$s,$S,$ts,$perl1,$perl2,$i,$rows,$ignore);
 213         }
 214     }
 215     $pgdbh->do("DROP TABLE matrix$i");
 216     $pgdbh->do("DROP TABLE distnames$i");
 217 }
 218
 219 sub write_new_line {
 220     my($S, $dist, $version, $s, $ts, $row_i, $rows_total, $perl1, $perl2, $serialized_perl_versions) = @_;
 221     $S->{"!CAND"}{$dist}{$version} = $s;
 222     my $outfile = "$ENV{HOME}/var/beforemaintrelease/result-$serialized_perl_versions";
 223     File::Path::mkpath File::Basename::dirname $outfile;
 224     { #JSON
 225         open my $fh, ">", "$outfile.new"  or die;
 226         print {$fh} $jsonxs->encode($S);
 227         close $fh or die $!;
 228         rename "$outfile.new", "$outfile.json" or die "Could not rename: $!";
 229     }
 230     { #TXT
 231         open my $fh, ">", "$outfile.new" or die;
 232         for my $k (sort keys %{$S->{"!CAND"}}){ # $k='Date-Formatter'
 233             for my $k2 (sort keys %{$S->{"!CAND"}{$k}}){ # $k2='0.11'
 234                 my $v = $S->{"!CAND"}{$k}{$k2};
 235                 no warnings 'uninitialized';
 236                 printf {$fh} "%-56s  %3d %3d    %3d %3d\n",
 237                                      "$k-$k2",
 238                                             $v->{$perl1}{pass}, $v->{$perl1}{fail},
 239                                                        $v->{$perl2}{pass}, $v->{$perl2}{fail};
 240             }
 241         }
 242         close $fh or die $!;
 243         rename "$outfile.new", "$outfile.txt" or die "Could not rename: $!";
 244     }
 245 }
 246
 247 sub store {
 248     my($dist,$version,$s,$S,$ts,$perl1,$perl2,$row_i,$rows_total,$ignore) = @_;
 249     my $serialized_perl_versions = join ":", map {
 250         my($lex) = lc($_);
 251         $lex =~ s/[\s\:\-]//g;
 252         $lex
 253     } $perl1, $perl2;
 254     unless ($ignore) {
 255         write_new_line($S, $dist, $version, $s, $ts, $row_i, $rows_total, $perl1, $perl2, $serialized_perl_versions);
 256     }
 257     if ($row_i == $rows_total) {
 258         use File::Spec ();
 259         my $overviewfile = "$ENV{HOME}/var/beforemaintrelease/overview.json";
 260         File::Path::mkpath File::Basename::dirname $overviewfile;
 261         my $lfh;
 262         until ($lfh = lockfilehandle($overviewfile)) {
 263             sleep 1;
 264         }
 265         my $slurp = do { local $/; <$lfh> };
 266         $slurp ||= "{}";
 267         my $O = $jsonxs->decode($slurp);
 268         $O->{$serialized_perl_versions} = $ts;
 269         seek $lfh, 0, 0;
 270         print {$lfh} $jsonxs->canonical->encode($O);
 271         truncate $lfh, tell $lfh;
 272         close $lfh or die "Could not close '$overviewfile': $!";
 273     }
 274 }
 275
 276 sub lockfilehandle {
 277     my($lockfile) = @_;
 278     use Fcntl ();
 279     use File::Basename ();
 280     use File::Path ();
 281     File::Path::mkpath File::Basename::dirname $lockfile;
 282     my $lfh;
 283     unless (open $lfh, "+<", $lockfile) {
 284         unless ( open $lfh, ">>", $lockfile ) {
 285             die "ALERT: Could not open >> '$lockfile': $!";
 286         }
 287         unless ( open $lfh, "+<", $lockfile ) {
 288             die "ALERT: Could not open +< '$lockfile': $!";
 289         }
 290     }
 291     if (flock $lfh, Fcntl::LOCK_EX|Fcntl::LOCK_NB) {
 292         # print "Info[$$]: Got the lock, continuing";
 293         return $lfh;
 294     } else {
 295         # print "FATAL[$$]: lockfile '$lockfile' locked by a different process";
 296         return undef;
 297     }
 298 }
 299
 300 # Local Variables:
 301 # mode: cperl
 302 # cperl-indent-level: 4
 303 # End: