bin/cron-comparing-5181-5182rc2.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 perl1 perl2
  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 =back
  28
  29 =head1 DESCRIPTION
  30
  31 Misnomer. We intended to write cronjob but settled with a one-off call
  32 for a start. We provide a json file and a txt file.
  33
  34 The generation took about 1-2 hours.
  35
  36 The text I wrote to p5p after 5.18.1 vs. 5.18.2 RC2 was:
  37
  38 Specifically, there was *no* case where 5.18.1 has only passes and
  39 5.18.2 has a fail. The following list of 118 distros presents all that
  40 have at least one fail in RC2 and at least a pass in 5.18.1.
  41
  42 =cut
  43
  44
  45 use FindBin;
  46 use lib "$FindBin::Bin/../lib";
  47 BEGIN {
  48     push @INC, qw(       );
  49 }
  50
  51 use Dumpvalue;
  52 use File::Basename qw(dirname);
  53 use File::Path qw(mkpath);
  54 use File::Spec;
  55 use File::Temp;
  56 use Getopt::Long;
  57 use Pod::Usage;
  58 use POSIX ();
  59 use Hash::Util qw(lock_keys);
  60
  61 our %Opt;
  62 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
  63 GetOptions(\%Opt,
  64            @opt,
  65           ) or pod2usage(1);
  66 if ($Opt{help}) {
  67     pod2usage(0);
  68 }
  69 my($perl1,$perl2) = @ARGV;
  70 $perl1 = '5.18.1' unless defined $perl1;
  71 $perl2 = '5.18.2 RC4' unless defined $perl2;
  72
  73 use FindBin;
  74 use lib "$FindBin::Bin/../CPAN-Blame/lib";
  75 use CPAN::Blame::Config::Cnntp;
  76
  77 use IPC::ConcurrencyLimit;
  78
  79 use DBI;
  80
  81 my($workdir);
  82 BEGIN {
  83     $workdir = File::Spec->catdir
  84         ($CPAN::Blame::Config::Cnntp::Config->{solver_vardir},
  85          "workdir");
  86 }
  87 my($basename) = File::Basename::basename(__FILE__);
  88 my $limit = IPC::ConcurrencyLimit->new
  89     (
  90      max_procs => 1,
  91      path      => "$workdir/IPC-ConcurrencyLimit-$basename",
  92     );
  93 my $limitid = $limit->get_lock;
  94 if (not $limitid) {
  95     warn "Another process appears to be still running. Exiting.";
  96     exit(0);
  97 }
  98
  99 my $pgdbh = DBI->connect("dbi:Pg:dbname=analysis") or die "Could not connect to 'analysis': $DBI::err";
 100
 101 $pgdbh->do("create temporary table distnames as (select distinct dist, version from cpanstats where perl=? and state='fail') ", undef, $perl2) or die;
 102 my $sth1 = $pgdbh->prepare("select dist, version from distnames");
 103 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");
 104
 105 use JSON::XS;
 106 my $jsonxs = JSON::XS->new->indent(1);
 107 my $S = {};
 108 my $ts = POSIX::strftime "%FT%T", gmtime($^T);
 109
 110 MAIN: {
 111     $sth1->execute;
 112     my $i = 0;
 113     my $rows = $sth1->rows;
 114
 115     while (my($dist,$version) = $sth1->fetchrow_array) {
 116         $i++;
 117         $sth2->execute($dist,$version,$perl1,$perl2);
 118         my $s;
 119         my %seen = (pass => 0, fail => 0);
 120         while (my($perl,$state,$count) = $sth2->fetchrow_array) {
 121             $s->{$perl}{$state} = $count;
 122             $seen{$state}++;
 123         }
 124         warn "calculated $i/$rows\n";
 125         if ($seen{fail} == 2 and $seen{pass} == 0) {
 126             next;
 127         }
 128         if ($seen{fail} == 2 and $seen{pass} == 2) {
 129             next;
 130         }
 131         store($dist,$version,$s);
 132         warn "wrote $i/$rows\n";
 133     }
 134 }
 135
 136 sub store {
 137     my($dist,$version,$s) = @_;
 138     $S->{$dist}{$version} = $s;
 139     my $outfile = "/home/andreas/var/compare-5181/result-$ts";
 140     {
 141         open my $fh, ">", "$outfile.new"  or die;
 142         print {$fh} $jsonxs->encode($S);
 143         close $fh or die $!;
 144         rename "$outfile.new", "$outfile.json" or die "Could not rename: $!";
 145     }
 146     {
 147         open my $fh, ">", "$outfile.new" or die;
 148         my $i = 0;
 149         for my $k (sort keys %$S){
 150             for my $k2 (sort keys %{$S->{$k}}){
 151                 my $v = $S->{$k}{$k2};
 152                 no warnings 'uninitialized';
 153                 printf {$fh} "%3d %-56s  %3d %3d    %3d %3d\n", ++$i, "$k-$k2", $v->{$perl1}{pass}, $v->{$perl1}{fail}, $v->{$perl2}{pass}, $v->{$perl2}{fail};
 154             }
 155         }
 156         close $fh or die $!;
 157         rename "$outfile.new", "$outfile.txt" or die "Could not rename: $!";
 158     }
 159 }
 160
 161 # Local Variables:
 162 # mode: cperl
 163 # cperl-indent-level: 4
 164 # End: