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<--oldperl=s@>
  28
  29 C<5.18.2>
  30
  31 =item B<--newperl=s@>
  32
  33 C<5.20.0 RC1>
  34
  35 =back
  36
  37 =head1 DESCRIPTION
  38
  39 We generate a json file and a txt file. The latter for myself to view
  40 the upcoming contents easily, the json for the webserver.
  41
  42 The generation took about 1-2 hours in the beginning but it got slower
  43 and slower, the more reports arrived.
  44
  45 =head1 HISTORY
  46
  47 formerly known as cron-comparing-5181-5182rc2.pl
  48
  49 =cut
  50
  51
  52 use FindBin;
  53 use lib "$FindBin::Bin/../lib";
  54 BEGIN {
  55     push @INC, qw(       );
  56 }
  57
  58 use Dumpvalue;
  59 use File::Basename qw(dirname);
  60 use File::Path qw(mkpath);
  61 use File::Spec;
  62 use File::Temp;
  63 use Getopt::Long;
  64 use Pod::Usage;
  65 use POSIX ();
  66 use Hash::Util qw(lock_keys);
  67
  68 our %Opt;
  69 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
  70 GetOptions(\%Opt,
  71            @opt,
  72           ) or pod2usage(1);
  73 if ($Opt{help}) {
  74     pod2usage(0);
  75 }
  76 $Opt{oldperl} = ['5.18.2']     unless $Opt{oldperl} && @{$Opt{oldperl}};
  77 $Opt{newperl} = ['5.20.0 RC1'] unless $Opt{newperl} && @{$Opt{newperl}};
  78 die "the arrayrefs for oldperl and newperl must be of same length, "
  79     . "found lengths %d and %d, cannot continue",
  80     scalar @{$Opt{oldperl}},
  81     scalar @{$Opt{newperl}}
  82     unless scalar @{$Opt{oldperl}}==scalar @{$Opt{newperl}};
  83
  84 use FindBin;
  85 use lib "$FindBin::Bin/../CPAN-Blame/lib";
  86 use CPAN::Blame::Config::Cnntp;
  87
  88 my $HAVE_IPCCL = eval { require IPC::ConcurrencyLimit; 1 };
  89 die unless $HAVE_IPCCL;
  90
  91 use DBI;
  92
  93 my($workdir);
  94 BEGIN {
  95     $workdir = File::Spec->catdir
  96         ($CPAN::Blame::Config::Cnntp::Config->{solver_vardir},
  97          "workdir");
  98 }
  99 my($basename) = File::Basename::basename(__FILE__);
 100 my $limit = IPC::ConcurrencyLimit->new
 101     (
 102      max_procs => 1,
 103      path      => "$workdir/IPC-ConcurrencyLimit-$basename",
 104     );
 105 my $limitid = $limit->get_lock;
 106 if (not $limitid) {
 107     warn "Another process appears to be still running. Exiting.";
 108     exit(0);
 109 }
 110
 111 my $pgdbh = DBI->connect("dbi:Pg:dbname=analysis") or die "Could not connect to 'analysis': $DBI::err";
 112 my $sth0 = $pgdbh->prepare("SELECT COUNT(*) FROM cpanstats WHERE perl=?");
 113 my $sth2 = $pgdbh->prepare("select perl, state, count(*) from cpanstats where dist=? and version=? and perl in (?,?) and state in ('pass','fail') group by perl, state");
 114 my $sth3 = $pgdbh->prepare("SELECT COUNT(distinct(dist||version)) FROM cpanstats WHERE perl=?");
 115 use JSON::XS;
 116 my $jsonxs = JSON::XS->new->indent(1);
 117
 118 for my $i (0..$#{$Opt{newperl}}) {
 119     my($perl1,$perl2);
 120     $perl1 = $Opt{oldperl}[$i];
 121     $perl2 = $Opt{newperl}[$i];
 122     unless ($perl1 && $perl2) {
 123         die "options oldperl and newperl are mandatory, found $perl1 vs $perl2";
 124     }
 125     $sth0->execute($perl2);
 126     my($total) = $sth0->fetchrow_array;
 127     $sth3->execute($perl2);
 128     my($totalrcdists) = $sth3->fetchrow_array;
 129
 130     # on the days 2016062[12] the smoker was of DCOLLINS was broken
 131     $pgdbh->do("CREATE temporary TABLE distnames$i AS
 132  ( SELECT DISTINCT dist, version FROM cpanstats
 133              WHERE perl=?
 134                AND state='fail'
 135                AND ( tester <> 'DCOLLINS\@cpan.org'
 136                      OR fulldate >= '201606230000'
 137                      OR fulldate <= '201606200000' )
 138  ) ", undef, $perl2) or die;
 139     my $sth1 = $pgdbh->prepare("select dist, version from distnames$i");
 140
 141     my $S =
 142         {
 143          "!ALL" => {
 144                     perls => [ $perl1, $perl2 ],
 145                     $perl2 => $total,
 146                     totalrcdists => $totalrcdists
 147                    },
 148         };
 149     my $ts = POSIX::strftime "%FT%T", gmtime(time);
 150
 151  MAIN: {
 152         $sth1->execute;
 153         my $i = 0;
 154         my $rows = $sth1->rows;
 155
 156         while (my($dist,$version) = $sth1->fetchrow_array) {
 157             $i++;
 158             $sth2->execute($dist,$version,$perl1,$perl2);
 159             my $s;
 160             my %seen = (pass => 0, fail => 0);
 161             while (my($perl,$state,$count) = $sth2->fetchrow_array) {
 162                 $s->{$perl}{$state} = $count;
 163                 $seen{$state}++;
 164             }
 165             warn "calculated $i/$rows\n";
 166             my $ignore = 0;
 167             if ($seen{fail} == 2 and $seen{pass} == 0) {
 168                 $ignore=1;
 169             }
 170             if ($seen{fail} == 2 and $seen{pass} == 2) {
 171                 $ignore=1;
 172             }
 173             store($dist,$version,$s,$S,$ts,$perl1,$perl2,$i,$rows,$ignore);
 174             warn "wrote $i/$rows\n";
 175         }
 176     }
 177 }
 178
 179 sub write_new_line {
 180     my($S, $dist, $version, $s, $ts, $row_i, $rows_total, $perl1, $perl2) = @_;
 181     $S->{"!CAND"}{$dist}{$version} = $s;
 182     my $outfile = "/home/andreas/var/beforemaintrelease/result-$ts";
 183     { #JSON
 184         open my $fh, ">", "$outfile.new"  or die;
 185         print {$fh} $jsonxs->encode($S);
 186         close $fh or die $!;
 187         rename "$outfile.new", "$outfile.json" or die "Could not rename: $!";
 188     }
 189     { #TXT
 190         open my $fh, ">", "$outfile.new" or die;
 191         for my $k (sort keys %{$S->{"!CAND"}}){ # $k='Date-Formatter'
 192             for my $k2 (sort keys %{$S->{"!CAND"}{$k}}){ # $k2='0.11'
 193                 my $v = $S->{"!CAND"}{$k}{$k2};
 194                 no warnings 'uninitialized';
 195                 printf {$fh} "%3d/%d %-56s  %3d %3d    %3d %3d\n",
 196                              $row_i, $rows_total,
 197                                      "$k-$k2",
 198                                             $v->{$perl1}{pass}, $v->{$perl1}{fail},
 199                                                        $v->{$perl2}{pass}, $v->{$perl2}{fail};
 200             }
 201         }
 202         close $fh or die $!;
 203         rename "$outfile.new", "$outfile.txt" or die "Could not rename: $!";
 204     }
 205 }
 206
 207 sub store {
 208     my($dist,$version,$s,$S,$ts,$perl1,$perl2,$row_i,$rows_total,$ignore) = @_;
 209     unless ($ignore) {
 210         write_new_line($S, $dist, $version, $s, $ts, $row_i, $rows_total, $perl1, $perl2);
 211     }
 212     if ($row_i == $rows_total) {
 213         use File::Spec ();
 214         my $overviewfile = "/home/andreas/var/beforemaintrelease/overview.json";
 215         my $lfh;
 216         until ($lfh = lockfilehandle($overviewfile)) {
 217             sleep 1;
 218         }
 219         my $slurp = do { local $/; <$lfh> };
 220         $slurp ||= "{}";
 221         my $O = $jsonxs->decode($slurp);
 222         $O->{join ":", $perl1, $perl2} = $ts;
 223         seek $lfh, 0, 0;
 224         print {$lfh} $jsonxs->canonical->encode($O);
 225         truncate $lfh, tell $lfh;
 226         close $lfh or die "Could not close '$overviewfile': $!";
 227     }
 228 }
 229
 230 sub lockfilehandle {
 231     my($lockfile) = @_;
 232     use Fcntl ();
 233     use File::Basename ();
 234     use File::Path ();
 235     File::Path::mkpath File::Basename::dirname $lockfile;
 236     my $lfh;
 237     unless (open $lfh, "+<", $lockfile) {
 238         unless ( open $lfh, ">>", $lockfile ) {
 239             die "ALERT: Could not open >> '$lockfile': $!";
 240         }
 241         unless ( open $lfh, "+<", $lockfile ) {
 242             die "ALERT: Could not open +< '$lockfile': $!";
 243         }
 244     }
 245     if (flock $lfh, Fcntl::LOCK_EX|Fcntl::LOCK_NB) {
 246         # print "Info[$$]: Got the lock, continuing";
 247         return $lfh;
 248     } else {
 249         # print "FATAL[$$]: lockfile '$lockfile' locked by a different process";
 250         return undef;
 251     }
 252 }
 253
 254 # Local Variables:
 255 # mode: cperl
 256 # cperl-indent-level: 4
 257 # End: