1 #!/home/src/perl/repoperls/installed-perls/perl/pVNtS9N/perl-5.8.0@32642/bin/perl -d
9 cnntp-contemplate - combine datacollections and annotations to recommendations
21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
25 defaults to C<perl.cpan.testers>.
29 defaults to something like ~/var/...
35 some code copy and pasted from cnntp-scrape...
39 show the most recent FAILs on cpantesters. Compare to annotations.txt
40 which I maintain manually.
58 use lib
"$ENV{HOME}/sources/CPAN/ghub/cpanpm/lib";
61 use File
::Basename
qw(dirname);
62 use File
::Path
qw(mkpath);
67 use List
::Util
qw(max min reduce sum);
68 use Pod
::Usage
qw(pod2usage);
79 $Opt{group
} ||= "perl.cpan.testers";
80 $Opt{baseuri
} ||= "http://www.nntp.perl.org/group";
82 my $workdir = $Opt{workdir
} ||= File
::Spec
->catdir(vardir
(\
%Opt),"workdir");
84 or die("Couldn't change to $workdir: $!");
86 $CPAN::Frontend
= "CPAN::Shell"; # alt: devnull
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; }
94 CPAN
::HandleConfig
->load;
95 CPAN
::Shell
::setup_output
;
98 my $db = read_local_db_for_month
(\
%Opt);
99 my $anno = read_annotations
(\
%Opt);
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";
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;
118 my @ret = cpan_lookup_dist
($dist);
119 my($upload_date,$author,$passfail_overview);
123 unless ($upload_date = $ret[0]->{UPLOAD_DATE
}) {
124 my($id) = $ret[0]->{ID
};
126 local($CPAN::Frontend
) = "CPAN::Shell::devnull";
127 CPAN
::Shell
->ls($id); # find out the upload date!
128 $upload_date = $ret[0]->upload_date || "???";
130 $author = substr($ret[0]{ID
},5);
132 $passfail_overview = passfail_overview
($dist,$db,$recent100000);
134 die "ALERT: not reached anymore";
139 $upload_date = "....-..-..";
140 $passfail_overview = "--:--:--";
143 for ($article->{from
}) {
144 substr($_,56)="..." if length>58;
146 my $ddist = length($dist)<=52 ?
$dist : (substr($dist,0,49)."...");
147 if (my($y,$m,$d) = $upload_date =~ /(\d+)-(\d+)-(\d+)/) {
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;
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");
160 $color_on = Term
::ANSIColor
::color
("red");
162 my $color_off = Term
::ANSIColor
::color
("reset");
163 $upload_date = "$color_on$upload_date$color_off";
166 "%2d %8d %s %s %s/%s\n",
177 sub ok_value_and_distro
{
179 $article->{subject
} =~ /(\S+)\s+(\S+)/;
182 sub passfail_overview
{
183 my($dist,$db,$recent100000) = @_;
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]";
196 push @
$recent100000, {
197 subject
=> $v->{subject
},
204 for my $v (@
$recent100000) {
205 next unless $dist eq $v->{dist
}; # XXX very inefficient
206 $summary{$v->{ok
}}++;
208 my $pass = delete $summary{PASS
};
209 my $fail = delete $summary{FAIL
};
210 my $other = sum
values %summary;
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");
222 sprintf "%s%2d:%2d:%2d%s", $color_on, $pass, $fail, $other||0, $color_off;
225 sub cpan_lookup_dist
{
227 my @ret = CPAN
::Shell
->expand("Distribution", "/\\/$dist/");
229 my $la = length(mybasename
($a->{ID
}));
230 my $lb = length(mybasename
($b->{ID
}));
233 return $best ?
$best : ();
243 my($opt,$month) = @_;
244 sprintf "%s/%s.yml", vardir
($opt), $month;
251 "%s/var/cnntp-scrape/%s",
257 sub read_local_db_for_month
{
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);
267 $y = YAML
::Syck
::LoadFile
($path);
271 if (scalar keys %{$y->{articles
}} < 100000) {
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);
279 $y2 = YAML
::Syck
::LoadFile
($path2);
280 while (my($k,$v) = each %{$y2->{articles
}}) {
281 $y->{articles
}{$k} = $v;
288 sub read_annotations
{
290 unless (open $fh, "../annotate.txt") {
299 my($dist,$splain) = split " ", $_, 2;
300 $anno->{$dist} = $splain;