bin/freshfirstfails.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<--days=f>
  24
  25 Defaults to 7. Is translated to
  26
  27   now() - interval 'N days'
  28
  29 =item B<--help|h!>
  30
  31 This help
  32
  33 =item B<--minpostdate=s>
  34
  35 Looks like an integer but stands for a month in the format YYYYMM.
  36 Actual DB range is 199908 to, at the time of this writing, 202202.
  37 Used to generate where clauses such as
  38
  39    ... where postdate >= $dbh->quote($Opt{minpostdate}) ...
  40
  41 Defaults to 202104.
  42
  43 B<Note: this should be changed to be a moving value similar to days> (once we are satisfied with the alpha version)
  44
  45 =item B<--urls!>
  46
  47 Provide relevant URLs and parts of URLs after each line
  48
  49 =back
  50
  51 =head1 DESCRIPTION
  52
  53 =head1 HISTORY
  54
  55 =head1 DEPLOYMENT
  56
  57 =cut
  58
  59
  60 use FindBin;
  61 use lib "$FindBin::Bin/../lib";
  62 BEGIN {
  63     push @INC, qw(       );
  64 }
  65
  66 use Dumpvalue;
  67 use File::Basename qw(dirname);
  68 use File::Path qw(mkpath);
  69 use File::Spec;
  70 use File::Temp;
  71 use Getopt::Long;
  72 use Pod::Usage;
  73 use POSIX ();
  74 use Hash::Util qw(lock_keys);
  75 use List::AllUtils qw(any);
  76
  77 our %Opt;
  78 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
  79 GetOptions(\%Opt,
  80            @opt,
  81           ) or pod2usage(1);
  82 if ($Opt{help}) {
  83     pod2usage(0);
  84 }
  85 $Opt{minpostdate} = '202104';
  86 $Opt{days} //= 7;
  87
  88 use FindBin;
  89 use lib "$FindBin::Bin/../CPAN-Blame/lib";
  90 use CPAN::Blame::Config::Cnntp;
  91
  92 my $ann = "/home/andreas/src/analysis-cpantesters-annotate/annotate.txt"; # !!! needs config support
  93 open my $fh, $ann or die "Could not open $ann: $!";
  94 my(%Annotations,%HalfAnnotations);
  95 while (<$fh>){
  96     my($d,$r) = /(\S+)\s+(.+)/;
  97     $Annotations{$d} = $r;
  98     $d =~ s/-v?[\d\._]+//;
  99     $HalfAnnotations{$d} = $r;
 100 }
 101
 102 use LWP::UserAgent;
 103 use JSON::XS;
 104 use CPAN::DistnameInfo;
 105 use List::AllUtils qw(reduce);
 106 use CPAN::Version;
 107
 108 my $ua = LWP::UserAgent->new();
 109 my $jsonxs = JSON::XS->new->indent(0);
 110
 111 use DBI;
 112
 113 my $pgdbh = DBI->connect("dbi:Pg:dbname=analysis") or die "Could not connect to 'analysis': $DBI::err";
 114 my $sth0 = $pgdbh->prepare("create temporary table x as (select dist, version, sum(case when state='pass' then cnt else 0 end) passes, sum(case when state='fail' then cnt else 0 end) fails from (select dist, version, state, count(*) cnt from cpanstats where postdate >= ? AND fulldate < now() - interval '$Opt{days} days' group by dist, version, state) x group by dist, version)");
 115 my $sth0i = $pgdbh->prepare("CREATE INDEX xdv ON x (dist, version)");
 116 my $sth1 = $pgdbh->prepare("select passes, fails from x where dist=? AND version=?");
 117 my $sth2 = $pgdbh->prepare("select version, passes, fails from x where dist=? order by version");
 118 my $sth3 = $pgdbh->prepare("select dist, version, state, fulldate, tester, perl, guid from cpanstats where (postdate >= ?) AND (fulldate > (now() - interval '$Opt{days} days')) order by fulldate"); # ignoring race between two values of now()
 119 my $sth4 = $pgdbh->prepare("update x set passes=? where dist=? AND version=?");
 120 my $sth5 = $pgdbh->prepare("update x set fails=? where dist=? AND version=?");
 121 my $sth6 = $pgdbh->prepare("INSERT INTO x values (?,?,0,0)");
 122
 123
 124 {
 125     $sth0->execute($Opt{minpostdate});
 126     $sth0i->execute();
 127     $sth3->execute($Opt{minpostdate});
 128
 129     my $i = 0;
 130     my $total = $sth3->rows;
 131     my %cand;
 132   ROW: while (my($dist,$version,$state,$fulldate,$tester,$perl,$guid) = $sth3->fetchrow_array) {
 133         ++$i;
 134         $sth1->execute($dist, $version);
 135         if ($sth1->rows == 0) {
 136             $sth6->execute($dist, $version);
 137             $sth1->execute($dist, $version);
 138         }
 139         my($passes, $fails) = $sth1->fetchrow_array;
 140         if ($state eq 'pass') {
 141             $passes++;
 142             $sth4->execute($passes, $dist, $version);
 143             next ROW;
 144         } elsif ($state eq 'fail') {
 145             unless ($fails) {
 146                 $cand{$dist}{$version}=1;
 147             }
 148             $fails++;
 149             $sth5->execute($fails, $dist, $version);
 150         } else {
 151             next ROW;
 152         }
 153         next ROW unless $passes;
 154         next ROW unless $cand{$dist};
 155         next ROW unless any { $fails==$_ } 1, 2, 3;
 156         my $short_tester = length($tester) < 40 ? $tester : substr($tester,0,40);
 157         $fulldate =~ s/:00\+00$//;
 158         printf "%6d %-39s %-16s %-11s %5d %2d %s %s %s\n", $i, $dist, $version, $perl, $passes, $fails, $fulldate, $guid, $short_tester;
 159         if ($Opt{urls}) {
 160             my $distv =  sprintf "%s-%s", $dist, $version;
 161             print "        $distv\n";
 162             my %w = ( distv => $distv, version => $version ); # work from metacpanapiquery, maybe not needed
 163             my $query = sprintf "http://fastapi.metacpan.org/v1/release/_search?q=distribution:%s&fields=name,date,status,version,author,archive&size=400&_source=tests", $dist;
 164             my $resp = $ua->get($query);
 165             unless ($resp->is_success) {
 166                 warn sprintf "No success visiting '%s': %s; sleeping %.3f\n",
 167                     $query, $resp->code;
 168                 next ROW;
 169             }
 170             # print $query;
 171             my $jsontxt = $resp->decoded_content;
 172             my $j = eval { $jsonxs->decode($jsontxt); };
 173             if (!$j || $@) {
 174                 my $err = $@ || "unknown error";
 175                 die "Error while decoding '$jsontxt': $err";
 176             }
 177             my $hits = $j->{hits}{hits};
 178             my($matchingrelease) = grep { $_->{fields}{name} eq $distv } @$hits;
 179             unless ($matchingrelease) {
 180                 warn "Did not find release for $distv\n";
 181                 next ROW;
 182             }
 183             my($releasedate) = $matchingrelease->{fields}{date};
 184             my($archive) = $matchingrelease->{fields}{archive};
 185             print "        releasedate: $releasedate\n";
 186             my($author) = $matchingrelease->{fields}{author};
 187             print "$author/$archive\n";
 188             # $DB::single = 1;
 189             # warn "x $matchingrelease";
 190             my $report_url = sprintf "http://www.cpantesters.org/cpan/report/$guid";
 191             print "$report_url\n";
 192         }
 193     }
 194     $i = 0;
 195     my $displayallcands = 0;
 196     if ($displayallcands) {
 197       DIST: for my $dist (sort keys %cand) {
 198             printf "%4d %s\n", ++$i, $dist;
 199             $sth2->execute($dist);
 200             my $j = 0;
 201           VERSION: while (my($version, $passes, $fails) = $sth2->fetchrow_array) {
 202                 next VERSION unless $cand{$dist}{$version};
 203                 my $anno_comment = "";
 204                 if (my $anno = $Annotations{sprintf "%s-%s", $dist, $version}) {
 205                     $anno_comment = " anno: $anno";
 206                 }
 207                 elsif (my $half_anno = $HalfAnnotations{$dist}) {
 208                     $anno_comment .= " hanno: $half_anno";
 209                 }
 210                 printf "    %4d %-20s %8d %8d%s\n", ++$j, $version, $passes, $fails, $anno_comment;
 211             }
 212         }
 213     }
 214     $pgdbh->do("DROP TABLE x");
 215 }
 216
 217 # Local Variables:
 218 # mode: cperl
 219 # cperl-indent-level: 4
 220 # End: