bin/cnntp-contemplate.pl

   1 #!/home/src/perl/repoperls/installed-perls/perl/pVNtS9N/perl-5.8.0@32642/bin/perl -d
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9 cnntp-contemplate - combine datacollections and annotations to recommendations
  10
  11 =head1 SYNOPSIS
  12
  13
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--group=s>
  24
  25 defaults to C<perl.cpan.testers>.
  26
  27 =item B<--workdir=s>
  28
  29 defaults to something like ~/var/...
  30
  31 =back
  32
  33 =head1 BUGS
  34
  35 some code copy and pasted from cnntp-scrape...
  36
  37 =head1 DESCRIPTION
  38
  39 show the most recent FAILs on cpantesters. Compare to annotations.txt
  40 which I maintain manually.
  41
  42 =head1 TODO
  43
  44 Is latest?
  45
  46 Release date
  47
  48 link to matrix
  49
  50 open tickets
  51
  52 result of -solve
  53
  54 my own results
  55
  56 =cut
  57
  58 use lib "$ENV{HOME}/sources/CPAN/ghub/cpanpm/lib";
  59 use CPAN;
  60 use DateTime;
  61 use File::Basename qw(dirname);
  62 use File::Path qw(mkpath);
  63 use File::Spec;
  64 use File::Temp;
  65 use Getopt::Long;
  66 use LWP::UserAgent;
  67 use List::Util qw(max min reduce sum);
  68 use Pod::Usage qw(pod2usage);
  69 use Term::ANSIColor;
  70 use URI ();
  71 use XML::LibXML;
  72 use YAML::Syck;
  73
  74 our %Opt;
  75 GetOptions(\%Opt,
  76            @opt,
  77           ) or pod2usage(1);
  78
  79 $Opt{group} ||= "perl.cpan.testers";
  80 $Opt{baseuri} ||= "http://www.nntp.perl.org/group";
  81
  82 my $workdir = $Opt{workdir} ||= File::Spec->catdir(vardir(\%Opt),"workdir");
  83 chdir $workdir
  84     or die("Couldn't change to $workdir: $!");
  85
  86 $CPAN::Frontend = "CPAN::Shell"; # alt: devnull
  87 {
  88     package CPAN::Shell::devnull;
  89     sub myprint { return; }
  90     sub mywarn { return; }
  91     sub mydie { my($self,$why) = @_; warn "Caught error[$why]; continuing"; return; }
  92     sub mysleep { return; }
  93 }
  94 CPAN::HandleConfig->load;
  95 CPAN::Shell::setup_output;
  96 CPAN::Index->reload;
  97
  98 my $db = read_local_db_for_month(\%Opt);
  99 my $anno = read_annotations(\%Opt);
 100 my $max = 50;
 101 my $i = 0;
 102 my %seen;
 103 my $highestreported = 0;
 104 my $recent100000 = [];
 105 ARTICLE: for my $k (sort {$b <=> $a} keys %{$db->{articles}}) {
 106     my $article = $db->{articles}{$k};
 107     my($ok,$dist) = ok_value_and_distro($article);
 108     unless ($highestreported++) {
 109         print "((($k))) $ok $dist\n";
 110     }
 111     next ARTICLE unless "FAIL" eq $ok;
 112     next ARTICLE if $seen{$dist}++;
 113     if (exists $anno->{$dist}) {
 114         my $anno = $anno->{$dist};
 115         substr($anno,36) = "..." if length($anno) > 39;
 116         printf "%s %8d skip %s (%s)\n", "-"x2, $k, $dist, $anno;
 117     } else {
 118         my @ret = cpan_lookup_dist($dist);
 119         my($upload_date,$author,$passfail_overview);
 120         if (@ret) {
 121             if (1 == @ret) {
 122                 # $DB::single=1;
 123                 unless ($upload_date = $ret[0]->{UPLOAD_DATE}) {
 124                     my($id) = $ret[0]->{ID};
 125                     $id =~ s|^./../||;
 126                     local($CPAN::Frontend) = "CPAN::Shell::devnull";
 127                     CPAN::Shell->ls($id); # find out the upload date!
 128                     $upload_date = $ret[0]->upload_date || "???";
 129                 }
 130                 $author = substr($ret[0]{ID},5);
 131                 $author =~ s|/.*||;
 132                 $passfail_overview = passfail_overview($dist,$db,$recent100000);
 133             } else {
 134                 die "ALERT: not reached anymore";
 135             }
 136         } else {
 137             next ARTICLE;
 138             $author = "???";
 139             $upload_date = "....-..-..";
 140             $passfail_overview = "--:--:--";
 141         }
 142         ++$i;
 143         for ($article->{from}) {
 144             substr($_,56)="..." if length>58;
 145         }
 146         my $ddist = length($dist)<=52 ? $dist : (substr($dist,0,49)."...");
 147         if (my($y,$m,$d) = $upload_date =~ /(\d+)-(\d+)-(\d+)/) {
 148
 149             my $dtu = DateTime->new(year => $y, month => $m, day => $d, time_zone => "floating");
 150             my $dtn = DateTime->now;
 151             my $dur = $dtn->subtract_datetime_absolute($dtu);
 152             my $delta = $dur->delta_seconds;
 153             my $color_on = "";
 154             # $DB::single++;
 155             if ($delta >= 3*365.25*86400) {
 156                 $color_on = Term::ANSIColor::color("yellow");
 157             } elsif ($delta >= 3*86400) {
 158                 $color_on = Term::ANSIColor::color("green");
 159             } else {
 160                 $color_on = Term::ANSIColor::color("red");
 161             }
 162             my $color_off = Term::ANSIColor::color("reset");
 163             $upload_date = "$color_on$upload_date$color_off";
 164         }
 165         printf(
 166                "%2d %8d %s %s %s/%s\n",
 167                $i, $k,
 168                $upload_date,
 169                $passfail_overview,
 170                $author,
 171                $ddist,
 172               );
 173     }
 174     last if $max == $i;
 175 }
 176
 177 sub ok_value_and_distro {
 178     my($article) = @_;
 179     $article->{subject} =~ /(\S+)\s+(\S+)/;
 180 }
 181
 182 sub passfail_overview {
 183     my($dist,$db,$recent100000) = @_;
 184     my %summary;
 185     unless (@$recent100000) {
 186         while (my($k,$v) = each %{$db->{articles}}) {
 187             # in january we had ~200000 articles
 188             # if we limit to 100000, then we have two week
 189             next if $k < $db->{max_article} - 100000;
 190             next if $v->{subject} eq "Oops";
 191             my($ok,$fdist) = ok_value_and_distro($v);
 192             unless (defined $fdist) {
 193                 warn "dist[$dist]fdist[$fdist]";
 194                 $DB::single++;
 195             }
 196             push @$recent100000, {
 197                                   subject => $v->{subject},
 198                                   from    => $v->{from},
 199                                   ok      => $ok,
 200                                   dist    => $fdist,
 201                                  };
 202         }
 203     }
 204     for my $v (@$recent100000) {
 205         next unless $dist eq $v->{dist}; # XXX very inefficient
 206         $summary{$v->{ok}}++;
 207     }
 208     my $pass = delete $summary{PASS};
 209     my $fail = delete $summary{FAIL};
 210     my $other = sum values %summary;
 211     my $color_on = "";
 212     my $color_off = "";
 213     $pass ||= 0;
 214     $fail ||= 0;
 215     if (0 == $pass) {
 216         $color_on = Term::ANSIColor::color("red");
 217         $color_off = Term::ANSIColor::color("reset");
 218     } elsif ($pass>=3 && $fail>=3) {
 219         $color_on = Term::ANSIColor::color("green");
 220         $color_off = Term::ANSIColor::color("reset");
 221     }
 222     sprintf "%s%2d:%2d:%2d%s", $color_on, $pass, $fail, $other||0, $color_off;
 223 }
 224
 225 sub cpan_lookup_dist {
 226     my($dist) = @_;
 227     my @ret = CPAN::Shell->expand("Distribution", "/\\/$dist/");
 228     my $best = reduce {
 229         my $la = length(mybasename($a->{ID}));
 230         my $lb = length(mybasename($b->{ID}));
 231         $la < $lb ? $a : $b
 232     } @ret;
 233     return $best ? $best : ();
 234 }
 235
 236 sub mybasename {
 237     my($p) = @_;
 238     $p =~ s|.*/||;
 239     return $p;
 240 }
 241
 242 sub dbpath {
 243     my($opt,$month) = @_;
 244     sprintf "%s/%s.yml", vardir($opt), $month;
 245 }
 246
 247 sub vardir {
 248     my($opt) = @_;
 249     sprintf
 250         (
 251          "%s/var/cnntp-scrape/%s",
 252          $ENV{HOME},
 253          $opt->{group},
 254         );
 255 }
 256
 257 sub read_local_db_for_month {
 258     my($opt) = @_;
 259     # take the max. Note: the server runs probably in some pacific
 260     # timezone, we really do not want to know.
 261     opendir my $dh, vardir($opt);
 262     my $current = reduce { $b gt $a ? $b : $a } grep {/^\d+-\d+\.yml$/} readdir $dh;
 263     my($month) = $current =~ /^(\d+-\d+)\.yml$/;
 264     my $path = dbpath($opt,$month);
 265     my $y;
 266     if (-e $path) {
 267         $y = YAML::Syck::LoadFile($path);
 268     } else {
 269         $y = +{};
 270     }
 271     if (scalar keys %{$y->{articles}} < 100000) {
 272         rewinddir $dh;
 273         my $current2 = reduce { $b gt $a ? $b : $a }
 274             grep {/^\d+-\d+\.yml$/ && $_ ne "$month.yml"} readdir $dh;
 275         my($month2) = $current2 =~ /^(\d+-\d+)\.yml$/;
 276         my $path2 = dbpath($opt,$month2);
 277         my $y2;
 278         if (-e $path2) {
 279             $y2 = YAML::Syck::LoadFile($path2);
 280             while (my($k,$v) = each %{$y2->{articles}}) {
 281                 $y->{articles}{$k} = $v;
 282             }
 283         }
 284     }
 285     return $y;
 286 }
 287
 288 sub read_annotations {
 289     my $fh;
 290     unless (open $fh, "../annotate.txt") {
 291         $DB::single=1;
 292         die "Could not";
 293     }
 294
 295     my $anno = {};
 296     while (<$fh>) {
 297         chomp;
 298         next if /^\s*$/;
 299         my($dist,$splain) = split " ", $_, 2;
 300         $anno->{$dist} = $splain;
 301     }
 302     return $anno;
 303 }
 304
 305 1;