bin/cnntp-solver.pl

   1 #!/home/src/perl/repoperls/installed-perls/perl/pVNtS9N/perl-5.8.0@32642/bin/perl
   2
   3 # use 5.012; # dor
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9 cnntp-solver - run cpan-testers-parsereport -solve over a bunch from the cpantesters DB
  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<--addctgargs=s>
  24
  25 Additional string to inject into the options that we pass to
  26 ctgetreports. Typically used together with --pick when there is
  27 something to grep for in the reports. E.g.
  28
  29   --pick RDF-NS-20130402 --addctgargs " --q qr:'(Bad blank node identifier.*)'"
  30
  31 =item B<--calcsample=i>
  32
  33 Defaults to arbitrary 500 on normal runs and to 2500 if pick is set. 0
  34 is treated as unlimited. If the number of passes and fails is so low
  35 that the expected numbers in the sample would be too low, then the
  36 sample is set higher, no matter what this parameter specifies.
  37
  38 =item B<--cpanstats_distrofacts=s>
  39
  40 For debugging only: string must consist of whitespace separated
  41 arguments $dist and $version (App-MusicExpo 1.002) or the more common
  42 $dist-$version (App-MusicExpo-1.002). Output is a JSON represenation
  43 of what the function cpanstats_distrofacts(undef,$dist,$version)
  44 returns.
  45
  46 =item B<--cpanstats_distrofacts_zero=s>
  47
  48 Like above but with resetting to zero beforehand.
  49
  50 =item B<--db_fixup_release_date=s>
  51
  52 For bug fixing only: string must consist of whitespace separated
  53 arguments $dist and $version. The function db_fixup_release_date will
  54 be called with these arguments and has the potential to fix a
  55 I<allversions> bug. Output is a bit unstructured.
  56
  57 =item B<--leavewhennojobsleft!>
  58
  59 If this option is true the program finishes when it (1) is only
  60 waiting for mincalctime and (2) the number of jobs in the jobsqueue
  61 drops to zero. It is not used to make the program wait for a longer
  62 time than mincalctime, the purpose is only to leave earlier when no
  63 reason to wait exists anymore. The purpose of mincalctime is to keep
  64 the shell loop around us trivial and the purpose of
  65 leavewhennojobsleft is to get back to work asap when the jobqueue is
  66 empty.
  67
  68 =item B<--maxfromannotate=i>
  69
  70 Per default we read all annotations from the file annotations.txt. But
  71 the maximum number we want to read can be set lower here. Useful when
  72 debugging the enqueing process of a certain package. Put this package
  73 into the first line and run
  74
  75  .../perl -d bin/cnntp-solver.pl --maxfromannotate=1 --maxfromsolved=0 --maxfromdb=0 --urgent
  76
  77 =item B<--maxfromdb=i>
  78
  79 Defaults to 666. Per default we read through the huge SQL query. We
  80 switch gears in the middle from thorough reading every row to skipping
  81 huge amounts of records randomly. But the maximum number we want to
  82 read at all can be set lower here.
  83
  84 =item B<--maxfromsolved=i>
  85
  86 Per default we read through all already previously solved
  87 calculations. But the maximum number we want to read can be set lower
  88 here.
  89
  90 =item B<--mincalctime=i>
  91
  92 When nothing left to do, let the script sleep until this amount of
  93 time has passed. Not interesting anymore. Redis queue takes over.
  94
  95 =item B<--pick=s>
  96
  97 Like a ctgetreports for this single item. We fake that it was found in
  98 annotations and skip all other steps. Pick per default implies
  99 sample=2500 but this can be overridden. Pick implies some kind of
 100 force in that we do not calculate whether a recalc is necessary
 101 depending on the age of a previous report. We simpy do it, regardless.
 102
 103 Maybe it's too much in the single parameter and we should separate some
 104 aspects out?
 105
 106 =item B<--retrieve_distrofacts=s>
 107
 108 For debugging only: string must consist of whitespace separated
 109 arguments $dist and $version. Output is a JSON represenation of what
 110 the function retrieve_distrofacts(undef,$dist,$version) returns.
 111
 112 =item B<--onlystartwhennojobs!>
 113
 114 If this option is true the program does not start as long as there are
 115 jobs in the queue.
 116
 117 =item B<--this_urgent=s>
 118
 119 For debugging only: string must consist of whitespace separated
 120 arguments $dist and $version. Output is a JSON represenation of what
 121 the function this_urgent(undef,$dist,$version) returns.
 122
 123 =item B<--urgent!>
 124
 125 Dangerous, use with care. Sets urgent globally for the whole run.
 126 Useful during debugging to avoid having to play dirty tricks with
 127 randomness.
 128
 129 =back
 130
 131 =head1 DESCRIPTION
 132
 133 Fulfills two roles on analysis: (1) enqueueing to redis is done by
 134 running this script from crontabs with different options; (2)
 135 dequeueing from redis is done by parallelized runs of this script with
 136 the C<--pick> option.
 137
 138 =head1 FUNCTIONS
 139
 140 =over 8
 141
 142 =cut
 143
 144 #use lib qw(    /usr/local/perl-5.10.1-uld/lib/5.10.1/x86_64-linux-ld
 145 #    /usr/local/perl-5.10.1-uld/lib/5.10.1
 146 #    /usr/local/perl-5.10.1-uld/lib/site_perl/5.10.1/x86_64-linux-ld
 147 #    /usr/local/perl-5.10.1-uld/lib/site_perl/5.10.1
 148 #);
 149 #use lib "/home/src/perl/CPAN-Testers-Common-Utils-0.002-82Cocq/blib/lib";
 150 #use lib "/home/src/perl/CPAN-Testers-Common-DBUtils-0.05-zqYV7K/blib/lib";
 151 #use lib "/home/src/perl/CPAN-Testers-Common-Article-0.42-4OIZRu/blib/lib";
 152 #use lib "/home/src/perl/CPAN-Testers-Data-Generator-0.41-bzdKLH/blib/lib";
 153 #use CPAN::Testers::Data::Generator;
 154     # methods discussed in CPAN::Testers::Common::DBUtils
 155     # schema in CPAN::WWW::Testers::Generator
 156
 157 use Digest::SHA;
 158 use File::Basename qw(dirname);
 159 use File::Path qw(mkpath);
 160 use File::Spec;
 161 use File::Temp;
 162 use Getopt::Long;
 163 use Hash::Util qw(lock_keys);
 164 use Pod::Usage qw(pod2usage);
 165 our %Opt;
 166 lock_keys %Opt, map { /([^=!]+)/ } @opt;
 167 GetOptions(\%Opt,
 168            @opt,
 169           ) or pod2usage(1);
 170 unless (defined $Opt{calcsample}) {
 171     if ($Opt{pick}) {
 172         $Opt{calcsample} = 2500; # arbitrary
 173     } else {
 174         $Opt{calcsample} = 500; # arbitrary
 175     }
 176 }
 177 $Opt{maxfromdb} = 666 unless defined $Opt{maxfromdb};
 178 sub mytouch ($$);
 179 sub cpanstats_distrofacts;
 180 sub retrieve_distrofacts;
 181 sub this_urgent;
 182
 183 use FindBin;
 184 use lib "$FindBin::Bin/../CPAN-Blame/lib";
 185 use CPAN::Blame::Config::Cnntp;
 186 my($workdir,$cpan_home,$ext_src);
 187 BEGIN {
 188     $workdir = File::Spec->catdir
 189         ($CPAN::Blame::Config::Cnntp::Config->{solver_vardir},
 190          "workdir");
 191     $cpan_home = $CPAN::Blame::Config::Cnntp::Config->{cpan_home};
 192     $ext_src = $CPAN::Blame::Config::Cnntp::Config->{ext_src};
 193 }
 194
 195 use lib "$ext_src/cpan-testers-parsereport/lib"
 196     #, "/home/src/perl/Config-Perl-V-0.10-ymOAl_/blib/lib"
 197     #, "/home/src/perl/DateTime-Format-DateParse-0.04-eYwnxv/blib/lib"
 198     ;
 199 use CPAN::Testers::ParseReport 0.002000; # we use it only indirectly but want
 200                                 # to fail early if it is missing
 201 use lib "$FindBin::Bin/../CPAN-Blame/lib";
 202 use Catalyst::Model;
 203 use CPAN::Blame::Model::Solved;
 204
 205 use lib "$ext_src/rersyncrecent/lib";
 206 use File::Rsync::Mirror::Recent;
 207
 208 use CPAN::DistnameInfo;
 209 use DateTime;
 210 use Time::Moment;
 211 use lib "$ext_src/rersyncrecent/lib";
 212 use LWP::UserAgent;
 213 use List::Util qw(max min minstr reduce sum);
 214 use List::MoreUtils qw(uniq);
 215 use Storable qw(dclone);
 216 use Term::ANSIColor;
 217 use Time::Duration qw(duration);
 218 use Time::HiRes qw(sleep);
 219 use Time::Local qw(timegm);
 220 use URI ();
 221 use YAML::Syck;
 222 use JSON::XS;
 223 use Redis;
 224
 225 use version; our $VERSION = qv('1.1.1');
 226
 227 ###### constants (mostly arbitrary) ######
 228 use constant MUST_CONSIDER => 1200; # 2015-06-03: current pause makes nearly 1500 per day
 229                                     # 2016-03-28: s/1400/1000/: try out whether it feels faster
 230 use constant MIN_CALCTIME => 20; # not interesting anymore, just a hot-loop-cooler
 231 use constant MAX_CALCTIME => 60*3600; # nonsense since redis we are done in no time
 232
 233 ###### debugging ######
 234
 235 if ($Opt{cpanstats_distrofacts_zero}) {
 236     $Opt{cpanstats_distrofacts} = $Opt{cpanstats_distrofacts_zero};
 237 }
 238 for my $func_name (qw(
 239     cpanstats_distrofacts
 240     retrieve_distrofacts
 241     db_fixup_release_date
 242     this_urgent
 243     )) {
 244     if (my $opt = $Opt{$func_name}) {
 245         my($dist,$version) = split " ", $opt;
 246         unless (defined $version && length $version){
 247             my $d = CPAN::DistnameInfo->new("FOO/$opt.tgz");
 248             $dist = $d->dist;
 249             $version = $d->version;
 250             unless (defined $version && length $version){
 251                 die "argument '$opt' could not be split";
 252             }
 253         }
 254         no strict 'refs';
 255         my $func = \&{$func_name};
 256         my $href = $func->(undef,$dist,$version);
 257         my $jsonxs = JSON::XS->new->pretty(1)->canonical(1);
 258         print $jsonxs->encode($href);
 259         exit;
 260     }
 261 }
 262
 263 ###### subroutines ######
 264
 265 =item ok_value_and_distro
 266
 267
 268
 269 =cut
 270 sub ok_value_and_distro {
 271     my($article) = @_;
 272     $article->{subject} =~ /(\S+)\s+(\S+)/;
 273 }
 274
 275 =item mydbi
 276
 277
 278
 279 =cut
 280 sub mydbi ($) {
 281     my $file = shift;
 282     require DBI;
 283     my $dbi = DBI->connect ("dbi:SQLite:dbname=$file");
 284 }
 285
 286 =item mypgdbi
 287
 288
 289
 290 =cut
 291 sub mypgdbi () {
 292     require DBI;
 293     my $dbi = DBI->connect ("dbi:Pg:dbname=analysis");
 294 }
 295
 296 =item myredis
 297
 298
 299
 300 =cut
 301 sub myredis () {
 302     my $redis = Redis->new(reconnect => 120, every => 1000);
 303 }
 304
 305 =item my_get_query
 306
 307
 308
 309 =cut
 310 sub my_get_query {
 311     my($dbi,$sql,@args) = @_;
 312     $dbi ||= mypgdbi();
 313     my $sth = $dbi->prepare($sql);
 314     my $rv = eval { $sth->execute(@args); };
 315     unless ($rv) {
 316         my $err = $sth->errstr;
 317         warn "Warning: error occurred while executing '$sql': $err";
 318     }
 319     my @rows;
 320     while (my(@trow) = $sth->fetchrow_array()) {
 321         push @rows, \@trow;
 322     }
 323     \@rows;
 324 }
 325
 326 =item my_do_query
 327
 328
 329
 330 =cut
 331 sub my_do_query {
 332     my($dbi,$sql,@args) = @_;
 333     local($dbi->{PrintError}) = 0;
 334     my $success = $dbi->do($sql,undef,@args);
 335     unless ($success) {
 336         my $err = $dbi->errstr;
 337         unless ($err =~ /duplicate key/) {
 338             require Carp;
 339             Carp::cluck(sprintf
 340                         (
 341                          "Warning: error occurred while executing sql[%s]with args[%s]: %s",
 342                          $sql,
 343                          join(":",map { defined $_ ? "'$_'" : "<undef>"} @args),
 344                          $err,
 345                         ));
 346         }
 347     }
 348     return $success;
 349 }
 350
 351 =item cpan_lookup_dist
 352
 353
 354
 355 =cut
 356 {
 357     package CPAN::Shell::devnull;
 358     sub myprint { return; }
 359     sub mywarn { return; }
 360     sub mydie { my($self,$why) = @_; warn "Caught error[$why]; continuing"; return; }
 361     sub mysleep { return; }
 362 }
 363 sub cpan_lookup_dist {
 364     my($mdbi,$dist,$version) = @_;
 365     return unless defined $dist && defined $version;
 366     my $distv = "$dist-$version";
 367     $mdbi ||= mypgdbi();
 368     my($author,$upload_date,$distroid) = db_memoized($mdbi,$distv);
 369     return ($author,$upload_date,$distroid)
 370         if $author && $upload_date && $distroid and $upload_date =~ /^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9] /;
 371
 372     # $DB::single = $dist eq "Net-Twitter" && $version eq "3.07002";
 373     # $DB::single = $dist eq "App-CLI-Plugin-Log-Message";
 374
 375     use lib "$ext_src/cpanpm/lib";
 376     our $CPAN_SETUP_DONE;
 377     unless ($CPAN_SETUP_DONE++) {
 378         require CPAN;
 379         CPAN::HandleConfig->load;
 380         CPAN::Shell::setup_output();
 381         CPAN::Index->reload;
 382     }
 383     $CPAN::Frontend = "CPAN::Shell"; # alt: devnull
 384     my @ret = CPAN::Shell->expand("Distribution", "/\\/$distv/");
 385     my $best = reduce {
 386         my $la = length(mybasename($a->{ID}));
 387         my $lb = length(mybasename($b->{ID}));
 388         $la < $lb ? $a : $b
 389     } @ret;
 390
 391     my($upload_date_authoritative) = 0;
 392     if ($best) {
 393         # $DB::single=1;
 394         my $oldyaml = read_ctx($distv);
 395         if ($oldyaml->{upload_date}
 396             and $oldyaml->{upload_date} =~ /^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9] /
 397             and $oldyaml->{upload_date} !~ /\?/) {
 398             $upload_date = $oldyaml->{upload_date};
 399         } elsif ($best->{UPLOAD_DATE}) {
 400             # not expected to happen
 401             $upload_date = $best->{UPLOAD_DATE}
 402         } elsif (my @stat = stat "$cpan_home/authors/id/$best->{ID}") {
 403             # $DB::single++;
 404             my(@mtime) = gmtime $stat[9];
 405             $mtime[4]++;
 406             $mtime[5]+=1900;
 407             $upload_date = sprintf "%04d-%02d-%02dT%02d:%02d:%02dz", @mtime[reverse 0..5];
 408             $upload_date_authoritative = 1;
 409         } else {
 410             # S-L-O-W
 411             my($id) = $best->{ID};
 412             $id =~ s|^./../||;
 413             local($CPAN::Frontend) = "CPAN::Shell::devnull";
 414             CPAN::Shell->ls($id); # find out the upload date
 415             $upload_date = $best->upload_date || "???";
 416         }
 417         $distroid = $author = substr($best->{ID},5);
 418         $author =~ s|/.*||;
 419     } elsif (my $x = find_on_cpan($dist,$version)) {
 420         my $absdistro = "$cpan_home/authors/$x";
 421         ($author) = $absdistro =~ m{.././../(.+?)/};
 422         ($distroid) = $absdistro =~ m{.././../(.+)$};
 423         if (my(@stat) = stat $absdistro) {
 424             my(@mtime) = gmtime $stat[9];
 425             $mtime[4]++;
 426             $mtime[5]+=1900;
 427             $upload_date = sprintf "%04d-%02d-%02d", @mtime[5,4,3];
 428         } else {
 429             # warn "Alert: Could not stat '$absdistro', will try to continue: $!";
 430             $upload_date = "....-..-..";
 431         }
 432     } else {
 433         # next ARTICLE;
 434         $author = "";
 435         my(@now) = gmtime;
 436         $now[4]++;
 437         $now[5]+=1900;
 438         $upload_date = sprintf "%04d-%02d-%02d(?)", @now[5,4,3];
 439         # leaving $distroid = undef;
 440     }
 441     db_memoize($mdbi,$distv,$author,$upload_date,$distroid,$upload_date_authoritative);
 442     return ($author,$upload_date,$distroid);
 443 }
 444
 445 =item db_memoized
 446
 447
 448
 449 =cut
 450 sub db_memoized {
 451     my($dbi,$distv) = @_;
 452     my $sql = "SELECT author,upload_date,distroid FROM distlookup WHERE distv=?";
 453     my $rows = my_get_query
 454         (
 455          $dbi,
 456          $sql,
 457          $distv
 458         );
 459     return unless @$rows;
 460     if (@$rows==1) {
 461         return @{$rows->[0]};
 462     } else {
 463         my $n = @$rows;
 464         die "Panic: cannot happen: '$n' rows when querying primary key '$distv'";
 465     }
 466 }
 467
 468 =item db_memoize($dbi,$distv)
 469
 470 =item db_memoize($dbi,$distv,$author,$upload_date,$distroid,$upload_date_authoritative)
 471
 472 First frm reserves a record, second form fills it a bit. Undefined
 473 values are ignored (*not* written as NULL).
 474
 475 =cut
 476 sub db_memoize {
 477     my($dbi,$distv,$author,$upload_date,$distroid,$upload_date_authoritative) = @_;
 478     my $sql = "INSERT INTO distlookup (distv) VALUES (?)";
 479     my $success = eval { my_do_query
 480         (
 481          $dbi,
 482          $sql,
 483          $distv,
 484         )};
 485     my(%othersets) =
 486         (
 487          author                 => $author,
 488          upload_date            => $upload_date,
 489          distroid               => $distroid,
 490          $upload_date_authoritative ? (release_date_metacpan  => $upload_date) : (),
 491         );
 492     my(@set, @bind);
 493     while (my($k,$v) = each %othersets) {
 494         if (defined $v) {
 495             push @set, "$k=?";
 496             push @bind, $v;
 497         }
 498     }
 499     return unless @bind; # they had no data
 500     push @bind, $distv;
 501     $sql =
 502         sprintf "UPDATE distlookup SET %s WHERE distv=?",
 503             join(", ", @set);
 504     eval { my_do_query
 505                (
 506                 $dbi,
 507                 $sql,
 508                 @bind,
 509                )};
 510     if ($@){
 511         warn "Error while processing '$distv' with sql[$sql]: $@";
 512     }
 513 }
 514
 515 =item mybasename
 516
 517
 518
 519 =cut
 520 sub mybasename {
 521     my($p) = @_;
 522     $p =~ s|.*/||;
 523     return $p;
 524 }
 525
 526 READ_ANNOTATIONS: {
 527     my %anno_line;
 528     sub read_annotations {
 529         use File::chdir;
 530         local($CWD) = "$FindBin::Bin/..";
 531         unless ($Opt{pick}) {
 532             for (0,1) {
 533                 last if 0 == system git => "pull"; # may fail
 534                 sleep 1;
 535             }
 536         }
 537         my $annofile = "$FindBin::Bin/../annotate.txt";
 538         my $fh;
 539         unless (open $fh, $annofile) {
 540             # $DB::single=1;
 541             die "Could not";
 542         }
 543
 544         my $anno = {};
 545         local $/ = "\n";
 546         my $i = 0;
 547     ANNOLINE: while (<$fh>) {
 548             chomp;
 549             next ANNOLINE if /^\s*$/;
 550             $i++;
 551             if (defined $Opt{maxfromannotate}) {
 552                 last ANNOLINE if $i > $Opt{maxfromannotate};
 553             }
 554             my($dist,$splain) = split " ", $_, 2;
 555             $anno->{$dist} = $splain;
 556             $anno_line{$dist} = $i;
 557         }
 558         return $anno;
 559     }
 560
 561 }
 562
 563 =item find_on_cpan
 564
 565
 566
 567 =cut
 568 sub find_on_cpan {
 569     my($dist,$version) = @_;
 570     return unless defined $dist;
 571     my $rf = File::Rsync::Mirror::Recent->new(local => "$cpan_home/authors/RECENT.recent");
 572     my $recent = $rf->news();
 573     my(@cand) = map
 574         {
 575             $recent->[$_]
 576         } grep
 577             {
 578                 $recent->[$_]{path} =~ m{/\Q$dist\E-\Q$version\E}
 579                     &&  $recent->[$_]{path} !~ m{(meta|readme)$}
 580                         # it doesn't matter if it is deleted, we found it!
 581                         # && $recent->[$_]{type} eq "new"
 582                     } 0..$#$recent;
 583     my @path = uniq map { $_->{path} } @cand;
 584     if (@path == 0) {
 585         return;
 586     } elsif (@path != 1){
 587         # e.g.
 588         # 0  'id/D/DR/DROLSKY/Moose-0.89_02.tar.gz'
 589         # 1  'id/D/DR/DROLSKY/Moose-0.89_01.tar.gz'
 590         # 2  'id/D/DR/DROLSKY/Moose-0.89.tar.gz'
 591         my $best = reduce {
 592             my $la = length($a);
 593             my $lb = length($b);
 594             $la < $lb ? $a : $b
 595         } @path;
 596         # $DB::single++;
 597         return $best;
 598     } else {
 599         return $path[0];
 600     }
 601 }
 602
 603 =item $href = cpanstats_distrofacts($dbi, $dist, $version, $distv, $lfh)
 604
 605 The original design of this function was and still is to query the
 606 C<cpanstats> table for all reports on B<dist> and not B<distv>. It
 607 then constructs the order of versions how they entered the database in
 608 C<allversions> and count pass and fail and other for this version and
 609 determine the third fail day.
 610
 611 A sample $href returned (slightly faked):
 612
 613   {
 614      "allversions" : [
 615         {
 616            "date" : "201302071447",
 617            "version" : "0.01"
 618         },
 619         {
 620            "date" : "201302111128",
 621            "version" : "0.02"
 622         },
 623         {
 624            "date" : "201303270850",
 625            "version" : "0.03"
 626         },
 627         {
 628            "date" : "201401241127",
 629            "version" : "0.04"
 630         }
 631      ],
 632      "db_fails" : 3,
 633      "db_others" : 2,
 634      "db_passes" : 1748,
 635      "thirdfail" : "2013-12-19 14:54",
 636      "thirdfailid" : 37664541,
 637      "thirdpass" : "2011-04-17 14:04",
 638      "thirdpassid" : 11739866
 639   }
 640
 641 Since this function can also be called from the option
 642 --cpanstats_distrofacts, the question is how well it works in
 643 concurrency. I *think* the algorithm is OK but I did not try to test
 644 for border cases. To avoid corruption we introduced the $lfh
 645 parameter.
 646
 647 If the $lfh is false, we try to get a lockfilehandle and hold it to
 648 the end. If it is a valid lockfilehandle, all the better.
 649
 650 =cut
 651 sub cpanstats_distrofacts {
 652     my($dbi,$dist,$version,$distv,$lfh) = @_;
 653     die "ALERT: illegal distname [$dist]" if $dist =~ /'/;
 654     $distv ||= "$dist-$version";
 655     unless ($lfh) {
 656         my $slv_file = slv_file($distv);
 657         $lfh = lockfilehandle("$slv_file.LCK") or return;
 658     }
 659     $dbi ||= db_quickaccess_handle();
 660     my($oldfacts) = retrieve_distrofacts($dbi,$dist,$version,$distv);
 661     # CUT: we do not yet use the oldfacts
 662     my($fails,       $passes,      $others,
 663        $thirdfailid, $thirdpassid, $alreadycounted,
 664        $thirdfail,   $thirdpass,   $cuti_reset)
 665         = @{$oldfacts}{qw(fails       passes      others
 666                           thirdfailid thirdpassid alreadycounted
 667                           thirdfail   thirdpass   cuti_reset
 668                         )};
 669     my $allversions = dclone $oldfacts->{allversions};
 670     my($maxid) = do {
 671         my $sql0 = "SELECT MAX(id) FROM cpanstats";
 672         my $rows0 = my_get_query($dbi, $sql0);
 673         $rows0->[0][0];
 674     };
 675     my $maxid_ts = Time::Moment->now_utc->to_string; # 2014-02-09T09:59:11.664143Z
 676     $alreadycounted ||= 0;
 677     my $sql = "SELECT id,version,fulldate,state
 678  FROM cpanstats
 679  WHERE dist=?
 680  AND id > ?
 681  AND id <= ?
 682  AND type=2 ORDER BY id";
 683     my $rows = my_get_query($dbi, $sql, $dist, $alreadycounted, $maxid);
 684     my(%seen,%xseen,%is_authoritative);
 685     for my $av (@$allversions) {
 686         $seen{$av->{version}}++; # prevent duplicates
 687         $xseen{$av->{version}}{$av->{date}}++; # preserve earliest date from previous runs
 688         if ($av->{authoritative}) {
 689             $is_authoritative{$av->{version}} = 1;
 690         }
 691     }
 692     $fails ||= 0;
 693     $passes ||= 0;
 694     $others ||= 0;
 695     for my $row (@$rows) {
 696         my($id,$v,$date,$state) = @$row; # id,version,fulldate,state
 697         if (defined $v){
 698             unless ($seen{$v}++) {
 699                 push @$allversions, { version => $v };
 700             }
 701             if (defined $version and $v eq $version) {
 702                 if ($state eq "fail") {
 703                     $fails++;
 704                     if (!$thirdfailid && $fails == 3) {
 705                         $thirdfail = $date; # format 200909190440
 706                         $thirdfailid = $id;
 707                     }
 708                 } elsif ($state eq "pass") {
 709                     $passes++;
 710                     if (!$thirdpassid && $passes == 3) {
 711                         $thirdpass = $date; # format 200909190440
 712                         $thirdpassid = $id;
 713                     }
 714                 } else {
 715                     $others++
 716                 }
 717             }
 718             $date = "" unless defined $date;
 719             $is_authoritative{$v} || $xseen{$v}{$date}++; # format 200909190440
 720         }
 721     }
 722     if ($thirdfail) {
 723         $thirdfail =~ s/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/$1-$2-$3 $4:$5z/;
 724     }
 725     if ($thirdpass) {
 726         $thirdpass =~ s/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/$1-$2-$3 $4:$5z/;
 727     }
 728     for my $v (@$allversions) {
 729         $v->{date} = minstr grep { length $_ } keys %{$xseen{$v->{version}}};
 730     }
 731     # sleep 0.25; # throttle
 732     my $facts =
 733         {
 734          allversions  => $allversions,
 735          thirdfail    => $thirdfail,
 736          thirdpass    => $thirdpass,
 737          thirdfailid  => $thirdfailid,
 738          thirdpassid  => $thirdpassid,
 739          db_fails     => $fails,
 740          db_passes    => $passes,
 741          db_others    => $others,
 742          db_maxid     => $maxid,
 743          db_maxid_ts  => $maxid_ts,
 744          cuti_reset   => $cuti_reset,
 745         };
 746     store_distrofacts($dbi,$dist,$distv,$oldfacts,$facts);
 747     return $facts;
 748 }
 749
 750 =item store_distrofacts
 751
 752 Cache the pass/fail/other counts, thirdfailid and thirdpassid, and the
 753 allversions structure. Remember the highest id up to which we have
 754 counted/observed so far, so we can start counting there next time.
 755
 756 =cut
 757 sub store_distrofacts {
 758     my($dbi,$dist,$distv,$oldfacts,$facts) = @_;
 759     no warnings 'uninitialized';
 760     {
 761         # do we need an insert first? See "insert missing" below
 762         db_memoize($dbi,$distv);
 763
 764         # then an update
 765         my $sql = "UPDATE distlookup
 766 SET cuti_fail=?,   cuti_pass=?,   cuti_others=?,
 767     thirdfailid=?, thirdpassid=?, counted_up_to_id=?,
 768     cuti_ts=?,     cuti_reset=?
 769 WHERE distv=?";
 770         my(%otherwhere);
 771         my @bind =
 772             (
 773              @{$facts}{qw(db_fails    db_passes   db_others
 774                           thirdfailid thirdpassid db_maxid
 775                           db_maxid_ts cuti_reset)},
 776              $distv,
 777             );
 778         @otherwhere{qw(fails       passes      others
 779                        thirdfailid thirdpassid alreadycounted
 780                        cuti_reset)}
 781             = qw(cuti_fail   cuti_pass   cuti_others
 782                  thirdfailid thirdpassid counted_up_to_id
 783                  cuti_reset);
 784         while (my($k,$v) = each %otherwhere) {
 785             if (defined $oldfacts->{$k}) {
 786                 $sql .= " AND $v=?";
 787                 push @bind, $oldfacts->{$k};
 788             } else {
 789                 $sql .= " AND $v IS NULL";
 790             }
 791         }
 792         my $sth = $dbi->prepare($sql);
 793         my $rv = $sth->execute(@bind);
 794         unless ($rv > 0) {
 795             my $bind = join ",", map { defined $_ ? "'$_'" : "<undef>" } @bind;
 796             warn "WARNING: $rv records updated with sql[$sql]bind[$bind]".
 797                 " => insert missing!";
 798         }
 799     }
 800     my $oldav = { map {("$dist-$_->{version}" => $_->{date})}
 801                   @{$oldfacts->{allversions}||[]}
 802                 };
 803     my $av = $facts->{allversions};
 804  DREF: for my $i (0..$#$av) {
 805         my $dref = $av->[$i] or next; # "distro-reference" { version=>"0.12", date=>"20070408" }
 806         my $tdistv = "$dist-$dref->{version}";
 807         my $tdate = $dref->{date};
 808         if ($i == $#$av and $tdate =~ /[0-9]{8}/) {
 809             eval { db_fixup_release_date($dbi,$dist,$dref->{version},$tdistv); };
 810             if ($@) {
 811                 warn "Warning: fixup complained [$@]";
 812             }
 813         }
 814         next DREF if $tdate && $oldav->{$tdistv} && $tdate eq $oldav->{$tdistv};
 815         db_quickaccess_insert_or_update($dbi,$tdistv,undef,undef,$dist);
 816         db_memoize($dbi,$tdistv,undef,$tdate,undef,0);
 817     }
 818     my $redis = myredis;
 819     my($fail,$pass) = @{$facts}{qw(db_fails db_passes)};
 820     #### hset missing in our ubuntu redis, using zscore as a workaround
 821     $redis->zadd("analysis:distv:pass",$pass,$distv) if defined $pass;
 822     $redis->zadd("analysis:distv:fail",$fail,$distv) if defined $fail;
 823
 824     return;
 825 }
 826
 827 =item retrieve_distrofacts
 828
 829 The distlookup and distcontext tables hold aggregate data that are
 830 generated from cpanstats (plus some). We update them on every run in
 831 store_distrofacts and reuse them next time we come by so that we do
 832 not have to read so much from cpanstats.
 833
 834 When a record has a zero for counted_up_to_id and one of the
 835 pass/fail/etc values are set, the whole record is reset. This means, a
 836 convenient way to restart counting is by resetting counted_up_to_id.
 837 For convenience, this reset can be triggered with the
 838 --cpanstats_distrofacts_zero option.
 839
 840 =cut
 841 sub retrieve_distrofacts {
 842     my($dbi,$dist,$version,$distv) = @_;
 843     $dbi ||= db_quickaccess_handle();
 844     $distv ||= "$dist-$version";
 845     my $facts = {};
 846     my $sth = $dbi->prepare("SELECT cuti_fail,   cuti_pass,   cuti_others,
 847                                     thirdfailid, thirdpassid, counted_up_to_id,
 848                                     cuti_reset
 849  FROM distlookup WHERE distv=?");
 850     $sth->execute($distv);
 851     my(@row) = $sth->fetchrow_array;
 852     @{$facts}{qw(fails passes others thirdfailid thirdpassid alreadycounted cuti_reset)} = @row;
 853     my @av;
 854     my $reset = $Opt{cpanstats_distrofacts_zero} || !$facts->{alreadycounted};
 855     unless ($reset) {
 856         my $cuti_reset ||= 0;
 857         if (time - $cuti_reset > 86400*90) {
 858             if (rand(1) < 0.001) {
 859                 $reset = 1;
 860             }
 861         }
 862     }
 863     if ($reset) {
 864         my $nil = {};
 865         @{$nil}{qw(db_fails db_passes db_others thirdfailid thirdpassid alreadycounted)} = ();
 866         $nil->{cuti_reset} = time;
 867         store_distrofacts($dbi,$dist,$distv,$facts,$nil);
 868         $facts = $nil;
 869     } else {
 870         $sth = $dbi->prepare("SELECT fulldate FROM cpanstats WHERE id=?");
 871         $sth->execute($facts->{thirdfailid});
 872         (@row) = $sth->fetchrow_array;
 873         $facts->{thirdfail} = $row[0];
 874         $sth->execute($facts->{thirdpassid});
 875         (@row) = $sth->fetchrow_array;
 876         $facts->{thirdpass} = $row[0];
 877         $sth = $dbi->prepare("SELECT distv FROM distcontext WHERE dist=?");
 878         my($sth2) = $dbi->prepare("SELECT upload_date, release_date_metacpan
 879  FROM distlookup
 880  WHERE distv=?");
 881         $sth->execute($dist);
 882         while (@row = $sth->fetchrow_array) {
 883             my($tdistv) = @row;
 884             my($v) = substr($tdistv,length($dist)+1);
 885             next unless $v;
 886             $sth2->execute($tdistv);
 887             my($tud,$trdmc) = $sth2->fetchrow_array;
 888             my($tdate) = $trdmc || $tud;
 889             next unless $tdate;
 890             $tdate =~ s/[^0-9]//g;
 891             next unless $tdate;
 892             substr($tdate,12)="" if length($tdate)>12;
 893             my $av = { version => $v, date => $tdate };
 894             $av->{authoritative} = 1 if $trdmc;
 895             push @av, $av;
 896         }
 897         @av = sort { $a->{date} cmp $b->{date}
 898                          || $a->{version} <=> $b->{version}
 899                              || $a->{version} cmp $b->{version}
 900                          } @av;
 901     }
 902     $facts->{allversions} = \@av;
 903     return $facts;
 904 }
 905
 906 =item $href = distroquestion($dbi,$i,$distroquestlabel,$dist,$version,$lfh)
 907
 908 (Called from three different places, and reacting to their context)
 909
 910 If the $lfh is false, we try to get a lockfilehandle and hold it to
 911 the end. If it is a valid lockfilehandle, all the better.
 912
 913 =cut
 914 sub distroquestion {
 915     my($dbi,$i,$distroquestlabel,$dist,$version,$lfh) = @_;
 916     my $distv = "$dist-$version";
 917     unless ($lfh) {
 918         my $slv_file = slv_file($distv);
 919         $lfh = lockfilehandle("$slv_file.LCK") or return;
 920     }
 921     my $greenish = 0;
 922     my($distro_age);
 923     my($author,$upload_date,$distroid) = cpan_lookup_dist($dbi,$dist,$version);
 924     my($tell_upload_date);
 925     my($csdfacts) = cpanstats_distrofacts($dbi,$dist,$version,$distv,$lfh);
 926     my($allversions) = $csdfacts->{allversions};
 927     my($thirdfail) = $csdfacts->{thirdfail};
 928     my $passfail_overview =
 929         {
 930          pass  => $csdfacts->{db_passes},
 931          fail  => $csdfacts->{db_fails},
 932          other => $csdfacts->{db_others},
 933         };
 934     my $tell_passfail_overview;
 935     my $ret =
 936         {
 937          allversions => $allversions,
 938          author => $author,
 939          dist => $dist,
 940          distroid => $distroid,
 941          distv => $distv,
 942          passfail_overview => $passfail_overview,
 943          thirdfail => $thirdfail,
 944          upload_date => $upload_date,
 945          version => $version,
 946         };
 947     {
 948         my $color_on = "";
 949         my $color_off = "";
 950         if (0 == $passfail_overview->{pass}) {
 951             $color_on = Term::ANSIColor::color("red");
 952             $color_off = Term::ANSIColor::color("reset");
 953         } elsif ($passfail_overview->{pass} >= 3 && $passfail_overview->{fail}>=3) {
 954             $color_on = Term::ANSIColor::color("green");
 955             $color_off = Term::ANSIColor::color("reset");
 956             $greenish++;
 957         }
 958         $tell_passfail_overview = sprintf
 959             ("%s%3d:%3d:%3d%s",
 960              $color_on,
 961              $passfail_overview->{pass},
 962              $passfail_overview->{fail},
 963              $passfail_overview->{other},
 964              $color_off,
 965             );
 966     }
 967     {
 968         my($y,$m,$d,$hour,$minute,$second) = $upload_date =~ /(\d+)-(\d+)-(\d+)(?:T(\d+):(\d+):(\d+))?/;
 969         if (not defined $y) {
 970             # ....-..-..
 971             printf "Warning: no upload date for %s\n", $ret->{distv};
 972             return $ret;
 973         }
 974         my $dtu = DateTime->new
 975             (year => $y,
 976              month => $m,
 977              day => $d,
 978              hour => $hour||0,
 979              minute => $minute||0,
 980              second => $second||0,
 981              time_zone => "floating", ### should change to utc, but may soon be unreachable
 982             );
 983         my $dtn = DateTime->now;
 984         my $dur = $dtn->subtract_datetime_absolute($dtu);
 985         $distro_age = $dur->delta_seconds;
 986         my $color_on = "";
 987         my $maxyears = $CPAN::Blame::Config::Cnntp::Config->{maxyears} || 8;
 988         if ($distro_age >= $maxyears*365.25*86400) {
 989             $color_on = Term::ANSIColor::color("yellow");
 990         } elsif ( $upload_date =~ /\?/) {
 991             $color_on = Term::ANSIColor::color("yellow");
 992         } elsif ($distro_age > 0) {
 993             $color_on = Term::ANSIColor::color("green");
 994             $greenish++;
 995         } else {
 996             $color_on = Term::ANSIColor::color("red");
 997         }
 998         my $color_off = Term::ANSIColor::color("reset");
 999         $tell_upload_date = $color_on . substr($upload_date,2,8) . $color_off;
1000     }
1001     my $tell_current_version;
1002     {
1003         my $current_version = @$allversions ? $allversions->[-1]{version} : 0;
1004         my $color_on = "";
1005         if ($current_version eq $version) {
1006             $tell_current_version = "current";
1007             $color_on = Term::ANSIColor::color("green");
1008             $greenish++;
1009         } elsif ($Opt{pick}) {
1010             $tell_current_version = "<?>";
1011             $color_on = Term::ANSIColor::color("green");
1012         } else {
1013             $tell_current_version = "<$current_version";
1014             $color_on = Term::ANSIColor::color("red");
1015         }
1016         my $color_off = Term::ANSIColor::color("reset");
1017         $tell_current_version = sprintf "%s%s%s", $color_on,$tell_current_version,$color_off;
1018     }
1019     my $ddist = length($distv)<=52 ? $distv : (substr($distv,0,49)."...");
1020     unless ($i % 50) {
1021         print "gmtime now: ".gmtime()."\n";
1022     }
1023     printf(
1024            "%3d %-8s %s %s %s/%s (%s)\n",
1025            $i, $distroquestlabel,
1026            $tell_upload_date,
1027            $tell_passfail_overview,
1028            $author || "???",
1029            $ddist,
1030            $tell_current_version,
1031           );
1032     my $slv_content = slv_content($distv);
1033     my $rtables = CPAN::Blame::Model::Solved->regression_tables($slv_content);
1034     my $rsq1_regressions = join ", ", map { $_->{name} } grep { $_->{rsq}==1 } @$rtables;
1035     $ret->{greenish} = $greenish;
1036     $ret->{distro_age} = $distro_age;
1037     $ret->{rsq1_regressions} = $rsq1_regressions;
1038     # sleep 0.5; # throttle
1039     return $ret;
1040 }
1041
1042 =item slv_file
1043
1044
1045
1046 =cut
1047 sub slv_file {
1048     my($distv) = @_;
1049     sprintf "%s/solved/%s.slv", $workdir, $distv;
1050 }
1051
1052 =item slv_content
1053
1054
1055
1056 =cut
1057 sub slv_content {
1058     my($distv) = @_;
1059     my $slv_file = slv_file($distv);
1060     return unless -e $slv_file;
1061     my $content = do { open my $fh, $slv_file or die "Could not open '$slv_file': $!";
1062                    local $/; <$fh> };
1063 }
1064
1065 =item lockfilehandle
1066
1067 =cut
1068 sub lockfilehandle {
1069     my($lockfile) = @_;
1070     use Fcntl qw( :flock );
1071     mkpath dirname $lockfile;
1072     my $lfh;
1073     unless (open $lfh, "+<", $lockfile) {
1074         unless ( open $lfh, ">>", $lockfile ) {
1075             die "ALERT: Could not open >> '$lockfile': $!"; # XXX should not die
1076         }
1077         unless ( open $lfh, "+<", $lockfile ) {
1078             die "ALERT: Could not open +< '$lockfile': $!"; # XXX should not die
1079         }
1080     }
1081     if (flock $lfh, LOCK_EX|LOCK_NB) {
1082         print "Info[$$]: Got the lock, continuing";
1083     } else {
1084         print "FATAL[$$]: lockfile '$lockfile' locked by a different process";
1085         return;
1086     }
1087     return $lfh;
1088 }
1089
1090
1091 =item call_ctgetreports
1092
1093
1094
1095 =cut
1096 sub call_ctgetreports {
1097     my($ctx,$ctxi,$ctxtotal) = @_;
1098     my($distv,$distro_age) = ($ctx->{distv},$ctx->{distro_age});
1099     my $slv_file = slv_file($distv);
1100     my @stat = stat ($slv_file . "dv.gz");
1101     unless (@stat) {
1102         @stat = stat ($slv_file . "dv");
1103     }
1104     my $slv_file_age = @stat ? time-$stat[9] : 0;
1105     # tuning this knob is always difficult for me. We are saying here
1106     # that we compare the age of the distro and the age of the
1107     # regression calculation we have around. Iow, older distros need
1108     # to be recalculated less often. If we increase this parameter
1109     # towards 1, we never calculate again because any result will be
1110     # younger than the distro. And if we go toward 0 we calculate
1111     # every time we come around. So if at 0.1 and with a very slow
1112     # pause2 we feel that 0.1 calculates too often, then we inc to
1113     # 0.25 to reduce the number of recalcs.
1114     my $must_run_ctgetreports;
1115     if ($Opt{pick}) {
1116         $must_run_ctgetreports = 1;
1117     } else {
1118         # tentative name for this variable? it is a relative age, a
1119         # threshold, and it guards recalculations:
1120         # RECALC_AGE_THRESHOLD? Sanity next time we come around
1121         $must_run_ctgetreports = !$slv_file_age || $slv_file_age > $distro_age*0.40; # arbitrary
1122     }
1123     # not allowed to go beyond this point without having a lock
1124     my $lfh = lockfilehandle("$slv_file.LCK") or return;
1125     if (!$must_run_ctgetreports && -e $slv_file && $slv_file_age > 86400) {
1126         # we want to overrule the decision for dists that have changed
1127         # much since last computation
1128         my $slv_content = slv_content($distv);
1129         my($calctimepass,$calctimefail) = (0,0);
1130         my @lines = split /\n/, $slv_content;
1131         for (@lines) {
1132             next unless /^ ([A-Z]+)/;
1133             if ($1 eq "PASS") {
1134                 $calctimepass++;
1135             } elsif ($1 eq "FAIL") {
1136                 $calctimefail++;
1137             }
1138         }
1139         if ($ctx->{passfail_overview}) {
1140             if (   $calctimepass && $ctx->{passfail_overview}{pass}/$calctimepass > 1.5  # arbitrary
1141                 || $calctimefail && $ctx->{passfail_overview}{fail}/$calctimefail > 1.5  # arbitrary
1142                ) {
1143                 $must_run_ctgetreports=1;
1144             }
1145         }
1146     }
1147     # its ugly to log within a subroutine and to log things that
1148     # belong to the outer scope and to pass parameters in we only need
1149     # for logging's sake:(
1150     printf
1151         ("DEBUG: at [%s UTC] for distv[%s] slv_file_age[%s] upload_date[%s] distro_age[%s] must_run_ctg[%s] progress[%d/%d]\n",
1152          scalar gmtime,
1153          $distv,
1154          $slv_file_age,
1155          $ctx->{upload_date},
1156          $distro_age,
1157          $must_run_ctgetreports,
1158          $ctxi,
1159          $ctxtotal,
1160         );
1161     if ($must_run_ctgetreports) {
1162         mkpath dirname $slv_file;
1163         my $dumpfile = $slv_file;
1164         $dumpfile =~ s/\.slv$/.slvdv/;
1165         if (-e "$dumpfile.gz") {
1166             0 == system "gunzip -f $dumpfile.gz" or die;
1167         }
1168         my $ctg = sprintf "%s/ctgetreports", dirname($^X);
1169         $ctg = "$ext_src/cpan-testers-parsereport/bin/ctgetreports";
1170         die "ctgetreports not installed" unless -e $ctg;
1171         my $ctg_cachedir = $CPAN::Blame::Config::Cnntp::Config->{ctgetreports_dir};
1172         my $hashed_ctg_parent;
1173         if (-d $ctg_cachedir) {
1174             my $letter = substr($distv,0,1);
1175             $hashed_ctg_parent = "$ctg_cachedir/$letter";
1176             if (-f "$hashed_ctg_parent/$distv.tar") {
1177                 0 == system qq{tar -C "$hashed_ctg_parent" -xf "$hashed_ctg_parent/$distv.tar"}
1178                     or die "Problem while untarring $distv.tar";
1179             }
1180         } else {
1181             die "directory '$ctg_cachedir' doesn't exist. Care to create it?";
1182         }
1183         my $sample = $Opt{calcsample};
1184         if ($sample && $ctx->{passfail_overview}{fail} && $ctx->{passfail_overview}{pass}) {
1185             # correct the sample size if there is a small amount of either fails or passes
1186             my $NF = $ctx->{passfail_overview}{fail};
1187             my $NP = $ctx->{passfail_overview}{pass};
1188             my $CRIT = min($NP,$NF);
1189             my $N = $NF + $NP;
1190             if ($CRIT * $sample / $N < 3) {
1191                 $sample = 1 + int(3.15 * $N / $CRIT); # 3.15 security margin over 3
1192             }
1193             if ($sample > $N){
1194                 # emergency break 2014-12-24:
1195                 # Class-C3-Componentised-1.001000 takes longer than 48
1196                 # hours, we must avert those; if the result is really
1197                 # interesting, we can expect that we'll get more fails
1198                 # in the following days
1199                 if ($sample > 3200) { # arbitrary: CGI-Struct with 3300 took 53000 seconds
1200                     warn "Alert: Late refusing of ctgetreports for $distv; sample too big: $sample";
1201                     return;
1202                 } else {
1203                     $sample = 0;
1204                 }
1205             }
1206         }
1207         my $sample_argument = $sample ? " --sample=$sample" : "";
1208         my $addctgargs = $Opt{addctgargs} || "";
1209         my $system =
1210             (
1211              qq{"$^X" -I "$ext_src/cpan-testers-parsereport/lib" "$ctg"}
1212              .qq{ --pce --cachedir="$hashed_ctg_parent/$distv"}
1213              .qq{ --q meta:from}
1214              .qq{ --q qr:'(.*version .+? required--this is only.*)'}
1215              .qq{ --q qr:'("[A-Za-z0-9_]+" is not exported by the [A-Za-z0-9_:]+ module.*)'}
1216              .qq{ --q qr:'(.*instance running.*)'}
1217              # cf Xref: k85.linux.bogus sent:7814
1218              #.qq{ --q qr:'(.*could.?n.t (?:open|connect).*)'}
1219              .qq{ --q qr:'(.*(?i:could.?n.t (?:open|connect|find)).*)'}
1220              .qq{ --q qr:'(.*Base class package.*)'}
1221              .qq{ --q qr:'(Can.t call method .*)'}
1222              .qq{ --q qr:'(Can.t use an undefined value.*)'}
1223              .qq{ --q qr:'(Can.t use string .*)'}
1224              .qq{ --q qr:'(Can.t modify division)'}
1225              .qq{ --q qr:'(Can\\047t locate loadable object)'}
1226              .qq{ --q qr:'(Connection (?:refused|reset by peer))'}
1227              .qq{ --q qr:'Constants from lexical variables potentially modified elsewhere are deprecated'}
1228              .qq{ --q qr:'(Can.t use keyword .*? as a label)'}
1229              .qq{ --q qr:'(Could not open .*)'}
1230              .qq{ --q qr:'(Address already in use)'}
1231              .qq{ --q qr:'(.*is deprecated (?:and will be removed)?)'}
1232              .qq{ --q qr:'(skip(?:ping |ped: | test).*)'}
1233              .qq{ --q qr:'(Please rerun the make command)'}
1234              .qq{ --q qr:'(v-string .* non-portable at \\S+)'}
1235              .qq{ --q qr:'(The module .* isn.t available on CPAN)'}
1236              .qq{ --q qr:'(Invalid version format)'}
1237              .qq{ --q qr:'did you mean \\\$\\] \\?'}
1238              .qq{ --q qr:'Unescaped left brace in regex is deprecated here, passed through'}
1239              .qq{ --q qr:'Unescaped left brace in regex is deprecated'}
1240              .qq{ --q qr:'Unescaped left brace in regex is illegal'}
1241              .qq{ --q qr:'Unknown warnings category'}
1242              .qq{ --q qr:'Non-ASCII character seen before =encoding'}
1243              .qq{ --q qr:'((Smartmatch|given|when) is experimental)'}
1244              .qq{ --q qr:'# (.+ alternative text .+ contains non-escaped .+)'}
1245              .qq{ --q qr:'=over without closing =back'}
1246              .qq{ --q qr:'starts or ends with whitespace'}
1247              .qq{ --q qr:'Acme::Override::INET replaced IO::Socket::INET'}
1248              .qq{ --q qr:'Invalid byte sequence'}
1249              .qq{ --q qr:'Insecure dependency in (require|eval)'}
1250              .qq{ --q qr:'Passing a list of values to enum'}
1251              .qq{ --q qr:'(undefined symbol: [A-Za-z0-9_]+ )'}
1252              .qq{ --q qr:'Bailout called\\.'}
1253              .qq{ --q qr:'Prototype mismatch:'}
1254              .qq{ --q qr:'Connection reset by peer'}
1255              .qq{ --q qr:'depends on targets in skipped section'}
1256              .qq{ --q qr:'Network error'}
1257              .qq{ --q qr:'Insecure .+ while running with'}
1258              .qq{ --q qr:'must be adjacent in regex'}
1259              .qq{ --q qr:'locate object method .new. via package .Test2::Context.'}
1260              .qq{ --q qr:'Use of code point 0x[[:xdigit:]]+ is deprecated; the permissible max is 0x7FFFFFFF'}
1261              .qq{ --q qr:'# (.+ but done_testing.+ expects .+)'}
1262              .$addctgargs
1263              .qq{ --solve --solvetop=123$sample_argument}
1264              .qq{ --dumpfile=$dumpfile}
1265              .qq{ --minpass=3}
1266              .qq{ --transport=http_cpantesters_gzip}
1267              .qq{ --prefer-local-reports}
1268              .qq{ --vdistro=$distv $ctx->{dist} > $slv_file.new 2>&1}
1269              .q{ --filtercb='my $r = shift; $r->{"meta:ok"} = "FILTERED" if $r->{"qr:locate object method .new. via package .Test2::Context."}'}
1270              .q{ --filtercb='my $r = shift; $r->{"meta:ok"} = "FILTERED" if $r->{"qr:Use of code point 0x[[:xdigit:]]+ is deprecated; the permissible max is 0x7FFFFFFF"}'}
1271              .q{ --filtercb='my $r = shift; for (split " ", $r->{"conf:ccflags"}){$r->{"conf:ccflags~$_"} = 1}'}
1272             );
1273         warn "Info: running system[$system]";
1274         my $ret = process_ctg($system, $distv);
1275         # gzip: /home/ftp/cnntp-solver-2009/workdir/solved/Dist-Zilla-Plugin-Twitter-0.015-TRIAL.slvdv: No such file or directory
1276         my $redis = myredis;
1277         $redis->zrem("analysis:distv:eta",$distv);
1278         if ($ret==0) {
1279             unless (0 == system "gzip -9f $dumpfile") {
1280                 warn "Warning: error while running gzip on '$dumpfile', continuing...";
1281                 return;
1282             }
1283             unless (0 == system
1284                     qq{tar -C "$hashed_ctg_parent" --remo -cf "$hashed_ctg_parent/$distv.tar" "$distv"}) {
1285                 warn "Warning: error while running tar cf on '$distv', continuing...";
1286                 return;
1287             }
1288             my @stat = stat "$dumpfile.gz";
1289             $redis->zadd("analysis:distv:calctimestamp",$stat[9],$distv) if @stat;
1290             my $lc_ts = Time::Moment->from_epoch($stat[9])->to_string; # lc=last calc
1291             open my $zfh, "-|", "zcat", "$dumpfile.gz" or die "could not fork: $!";
1292             my $j = do {local $/; <$zfh>};
1293             use JSON::XS;
1294             my $h = JSON::XS->new->decode($j);
1295             my %passfail = map { $_ => $h->{"meta:ok"}{$_}{$_} } qw(PASS FAIL);
1296             for my $pf (qw(pass fail)) {
1297                 my $redis_key = "analysis:distv:lc$pf"; # analysis:distv:lcpass
1298                 my $pf_value = $passfail{uc $pf} // 0;  # $passfail{PASS}
1299                 $redis->zadd($redis_key, $pf_value, $distv);
1300             }
1301             rename "$slv_file.new", $slv_file or die "Could not rename: $!";
1302             mytouch("slv",{name => $distv});
1303             return {
1304                     lfh => $lfh,
1305                     lc_ts => $lc_ts,
1306                     lc_pass => $passfail{PASS}//0,
1307                     lc_fail => $passfail{FAIL}//0,
1308                    }; # did it!
1309         } else {
1310             warn "Alert: Error running ctgetreports; command was [$system]";
1311             return;
1312         }
1313     } else {
1314         return;
1315     }
1316 }
1317
1318 {
1319     my($old_highscore);
1320     sub enqueue {
1321         my($distv,$want_ctgetreport,$ctxi) = @_;
1322         if ($distv eq "libxml-enno-1.02") {
1323             require Carp;
1324             Carp::cluck("$distv is generally unwanted, go away.");
1325             sleep 60;
1326             return;
1327         }
1328         my $redis = myredis;
1329         unless (defined $old_highscore) {
1330             my($topdistv,$highscore) = $redis->zrevrange("analysis:jobqueue:q",0,0,"withscores");
1331             $old_highscore = $highscore;
1332             $old_highscore //= 0;
1333         }
1334         my($thisscore) = $redis->zscore("analysis:jobqueue:q",$distv);
1335         $thisscore //= 0;
1336         my $score = $want_ctgetreport - $ctxi; # linear decreasing
1337         if ($ctxi < 40 && $old_highscore > $score) {
1338             # the first 40 deserve a better score than the old ones
1339             $score = $old_highscore + 40 - $ctxi;
1340         }
1341         if ($score<=0) {
1342             $score = 1;
1343         }
1344         if ($thisscore >= $score) {
1345             # nothing to do
1346             return;
1347         }
1348         my $debug = 1;
1349         if ($debug) {
1350             my($zcard) = $redis->zcard("analysis:jobqueue:q");
1351             warn "DEBUG: enqueueing ctxi[$ctxi] old_highscore[$old_highscore] score[$score] distv[$distv] zcard[$zcard]\n";
1352         }
1353         $redis->zadd("analysis:jobqueue:q", $score, $distv);
1354     }
1355 }
1356
1357 =item process_ctg
1358
1359 Runs a ctgetreports job with all of our redis interaction
1360
1361 Revisited 2015-04-06: looks wrong to me. But remember, we have redis
1362 1.2 on our ds8143 and that did not even have a hash. That's for
1363 example why we used JSON::XS here, we could have used hash instead.
1364 But I'm sure that the "pattern" that I was reading in the Redis
1365 documentation at that time has changed significantly since then. Maybe
1366 we should rewrite the code according to the current description.
1367
1368 =cut
1369 sub process_ctg {
1370     my($system, $distv) = @_;
1371     my $start = time;
1372     my $redis = myredis;
1373     my $jsonxs = JSON::XS->new->indent(0);
1374     my $job_object = {distv=>$distv,start=>$start};
1375     my $json = $jsonxs->encode($job_object);
1376     my $sha1 = Digest::SHA->new(1);
1377     $sha1->add($json);
1378     my $hex = $sha1->hexdigest;
1379     my $id = $redis->get("analysis:jobqueue:jobs:$hex\:id");
1380     unless ($id) {
1381         my($nid) = $redis->incr("analysis:jobqueue:next.job.id");
1382         if (my($setnx) = $redis->setnx("analysis:jobqueue:jobs:$hex\:id" => $nid)) {
1383             $id = $nid;
1384         } else {
1385             warn "WARNING: Should never happen, it would mean that two jobs calc the same thing at the same time. json[$json]hex[$hex]";
1386             $id = $redis->get("analysis:jobqueue:jobs:$hex\:id");
1387         }
1388     }
1389     $redis->set("analysis:jobqueue:jobs:$id\:descr" => $json); # will set again afterwards
1390     $redis->set("analysis:jobqueue:jobs:$id\:hex" => $hex);
1391     $redis->sadd("analysis:jobqueue:runningjobs" => $id); # must srem
1392     my $ret = system $system;
1393     my $finished = time;
1394     my $took = $finished - $start;
1395     $job_object->{finished} = $finished;
1396     $job_object->{took} = $took;
1397     $job_object->{ret} = $ret;
1398     $json = $jsonxs->encode($job_object);
1399     $redis->set("analysis:jobqueue:jobs:$id\:descr" => $json); # setting again
1400     $redis->srem("analysis:jobqueue:runningjobs" => $id); # as promised
1401     $redis->rpush("analysis:jobqueue:recentjobs" => $id);
1402     while ($redis->llen("analysis:jobqueue:recentjobs") > 10000) {
1403         my($del_id) = $redis->lpop("analysis:jobqueue:recentjobs");
1404         my($del_hex) = $redis->get("analysis:jobqueue:jobs:$del_id\:hex");
1405         $redis->del("analysis:jobqueue:jobs:$del_hex\:id");
1406         $redis->del("analysis:jobqueue:jobs:$del_id\:descr");
1407         $redis->del("analysis:jobqueue:jobs:$del_id\:hex");
1408     }
1409     if ($took > 3600) {
1410         warn "Warning: slow calc on '$distv'; took[$took]";
1411     }
1412     return $ret;
1413 }
1414
1415 =item read_ctx
1416
1417 Reads the context of this distv from the yaml file
1418
1419 =cut
1420 sub read_ctx {
1421     my($distv) = @_;
1422     my $outfile = sprintf "%s/solved/%s.yml", $workdir, $distv;
1423     my @stat = stat $outfile or return;
1424     YAML::Syck::LoadFile($outfile);
1425 }
1426
1427 =item store_ctx ($dbi,$ctx)
1428
1429 $dbi may be undef. (For the record, we often have no dbi handle
1430 around, but if we have one, we want to pass it around. This has its
1431 historical reason in sqlite's misbehaving when faced with concurrent
1432 accesses. So we tried to keep the lifespan of dbi handles as short as
1433 possible.)
1434
1435 Checks the hashref $ctx against the yaml file on disk, writes it if
1436 something has changed. Then writes it also to the database. If this is
1437 a first-time encounter and greenish is >= 3, it is also enqueued for a
1438 first calc.
1439
1440 =cut
1441 sub store_ctx {
1442     my($dbi,$ctx) = @_;
1443     my $outfile = sprintf "%s/solved/%s.yml", $workdir, $ctx->{distv};
1444     my @stat = stat $outfile;
1445     my $want_write = 0;
1446     my $want_enqueue = 0;
1447     {
1448         my $reduced_ctx = dclone $ctx;
1449         delete $reduced_ctx->{distro_age};
1450         my $curr_dump = YAML::Syck::Dump($reduced_ctx);
1451         if (@stat) {
1452             my $last_dump = do
1453                 { open my $fh, $outfile or die "Could not open '$outfile': $!";
1454                   local $/;
1455                   <$fh>;
1456               };
1457             $want_write = $curr_dump ne $last_dump;
1458             no warnings 'uninitialized';
1459             if ($want_write and $ctx->{lastcalc} and $ctx->{passfail_overview}) {
1460                 my $old_ctx = YAML::Syck::Load($last_dump);
1461                 if ($ctx->{lastcalc} ne $old_ctx->{lastcalc}) {
1462                     # distlookup: last_calc_ts, lc_pass, lc_fail
1463                     db_store_lastcalc(
1464                         $dbi,
1465                         $ctx->{distv},
1466                         $ctx->{lastcalc},
1467                         $ctx->{lc_pass},
1468                         $ctx->{lc_fail},
1469                     );
1470                 }
1471             }
1472         } else {
1473             $want_write = 1;
1474             if ($ctx->{greenish} && $ctx->{greenish} >= 3) {
1475                 $want_enqueue = 1;
1476             }
1477         }
1478         if ($want_write) {
1479             mkpath dirname $outfile;
1480             open my $fh, ">", "$outfile.new" or die "Could not open > '$outfile.new': $!";
1481             print $fh $curr_dump;
1482             close $fh or die "Could not close: $!";
1483             rename "$outfile.new", $outfile or die "Could not rename: $!";
1484         }
1485         db_quickaccess_insert_or_update
1486             (
1487              undef,
1488              $ctx->{distv},
1489              $curr_dump,
1490              $ctx->{greenish},
1491              $ctx->{dist},
1492             );
1493     }
1494     if ($want_enqueue) {
1495         enqueue($ctx->{distv},0,1);
1496     }
1497     mytouch("yml",{name => $ctx->{distv}});
1498 }
1499
1500 =item db_quickaccess_handle
1501
1502
1503
1504 =cut
1505 sub db_quickaccess_handle {
1506     return CPAN::Blame::Config::Cnntp::common_quickaccess_handle();
1507 }
1508
1509 =item db_quickaccess_insert_or_update
1510
1511 Convenience function for getting stuff into distcontext table. You
1512 cannot set anything to null here, only to some value. Any value given
1513 as undef is skipped in the generated update statement. Against common
1514 best practice, this code first looks whether a record exists and only
1515 does an insert if it does not exist. We believe this is OK since we
1516 never want to delete records here.
1517
1518 Besides that, this function does nothing when the caller would not
1519 change anything.
1520
1521 =cut
1522 sub db_quickaccess_insert_or_update {
1523     my($dbi,$distv,$yaml,$greenish,$dist) = @_;
1524     $dbi ||= db_quickaccess_handle();
1525     my $sql = "SELECT yaml,greenish,dist FROM distcontext WHERE distv=?";
1526     my $rows = my_get_query
1527         (
1528          $dbi,
1529          $sql,
1530          $distv
1531         );
1532     if (!@$rows) {
1533         $sql = "INSERT INTO distcontext (distv) VALUES (?)";
1534         my_do_query
1535             (
1536              $dbi,
1537              $sql,
1538              $distv
1539             );
1540     }
1541     no warnings 'uninitialized';
1542     my(%othersets) = (yaml => $yaml, greenish => $greenish, dist => $dist);
1543     my(%oldvalues) =
1544         (
1545          yaml     => $rows->[0][0],
1546          greenish => $rows->[0][1],
1547          dist     => $rows->[0][2],
1548         );
1549     my(@set, @bind);
1550     while (my($k,$v) = each %othersets) {
1551         if (defined $v && $v ne $oldvalues{$k}) {
1552             push @set, "$k=?";
1553             push @bind, $v;
1554         }
1555     }
1556     return unless @bind;
1557     push @bind, $distv;
1558     # $sql = "UPDATE distcontext SET yaml=?, greenish=?, dist=? WHERE distv=?";
1559     $sql = sprintf "UPDATE distcontext SET %s WHERE distv=?", join(", ", @set);
1560     warn "DEBUG: sql[$sql] bind[@bind]";
1561     my_do_query($dbi, $sql, @bind);
1562 }
1563
1564 =item db_quickaccess_delete
1565
1566 forbidden call, because we believe that we want to keep distv=>dist
1567 relation here forever and in any case. We use that relation in
1568 allversions stuff.
1569
1570 =cut
1571 sub db_quickaccess_delete {
1572     my($distv) = @_;
1573     require Carp;
1574     Carp::confess("somebody called db_quickaccess_delete");
1575     my $dbi = db_quickaccess_handle();
1576     my $sql = "DELETE FROM distcontext WHERE distv=?";
1577     my_do_query
1578         (
1579          $dbi,
1580          $sql,
1581          $distv
1582         );
1583 }
1584
1585 =item mytouch
1586
1587
1588 =cut
1589 sub mytouch ($$) {
1590     my($type,$message) = @_;
1591     my $file = sprintf "%s/solved/lastchange_%s.ts", $workdir, $type;
1592     open my $fh, ">", $file or die "Could not open >'$file': $!";
1593     print $fh YAML::Syck::Dump($message);
1594     close $fh or die "Could not close '$file': $!";
1595 }
1596
1597 =item age_in_secs
1598
1599
1600
1601 =cut
1602 sub age_in_secs {
1603     my($iso) = @_;
1604     my @date = unpack "a4 a1 a2 a1 a2", $iso; # 2006-07-04
1605     $date[2]--; # make month zero-based
1606     my $epoch = eval {  timegm(0,0,0,@date[4,2,0]);  };
1607     if ($@ || !$epoch) {
1608         require Carp;
1609         Carp::confess("ALERT: date[@date] iso[$iso]");
1610     }
1611     time - $epoch;
1612 }
1613
1614 =item db_quickaccess_select_dist
1615
1616
1617
1618 =cut
1619 sub db_quickaccess_select_dist {
1620     my($dbi,$distv) = @_;
1621     my $sql = "SELECT dist FROM distcontext WHERE distv=?";
1622     my $rows = my_get_query
1623         (
1624          $dbi,
1625          $sql,
1626          $distv
1627         );
1628     return unless @$rows>0;
1629     return $rows->[0][0];
1630 }
1631
1632 =item db_fixup_release_date
1633
1634 Fetch a release date from metacpan and write it into
1635 release_date_metacpan in distlookup. Dies if the field is not empty.
1636
1637 =cut
1638 sub db_fixup_release_date {
1639     my($dbi,$dist,$version,$distv) = @_;
1640     $dbi ||= db_quickaccess_handle();
1641     $distv ||= "$dist-$version";
1642     my $sql = "SELECT release_date_metacpan FROM distlookup WHERE distv=?";
1643     my $rows = my_get_query
1644         (
1645          $dbi,
1646          $sql,
1647          $distv
1648         );
1649     if (defined $rows->[0][0] and length $rows->[0][0]) {
1650         die "Alert: found record for distv '$distv' where release_date_metacpan is '$rows->[0][0]'";
1651     }
1652     my $ua = LWP::UserAgent->new(agent => "analysis.cpantesters.org/$VERSION");
1653     $ua->default_header("Accept-Encoding", "gzip");
1654     my $jsonxs = JSON::XS->new->indent(0);
1655     # my $query = "http://api.metacpan.org/v0/release/_search?q=release.name:$distv&fields=name,date,status";
1656     my $query = "http://fastapi.metacpan.org/v1/release/_search?q=name:$distv&fields=name,date,status";
1657     my $resp = $ua->get($query);
1658     my $date;
1659     if ($resp->is_success) {
1660         my $content = $resp->decoded_content;
1661         my $mcpananswer = $jsonxs->decode($content);
1662         if (my $h = $mcpananswer->{hits}{hits}) {
1663             $date = $h->[0]{fields}{date};
1664         } else {
1665             warn sprintf "Warning: result from metacpan api has no hits: %s\n", $content;
1666         }
1667     } else {
1668         die sprintf "No success getting from metacpan: query '%s' response '%s'", $query, $resp->as_string;
1669     }
1670     warn sprintf "DEBUG: rows[%d] distv[%s] dist[%s] date[%s]\n", scalar @$rows, $distv, $dist, $date;
1671     $sql = "UPDATE distlookup set release_date_metacpan=? WHERE distv=?";
1672     my $success = my_do_query($dbi,$sql,$date,$distv);
1673     return
1674         +{
1675           success => $success,
1676          };
1677 }
1678
1679 =item (void) db_store_lastcalc ($dbi, $distv, $last_calc_ts, $lc_pass, $lc_fail)
1680
1681 Stores the last calc's coordinates. Short-circuits if they are already there.
1682
1683 =cut
1684 sub db_store_lastcalc {
1685     my($dbi, $distv, $last_calc_ts, $lc_pass, $lc_fail) = @_;
1686     $dbi ||= db_quickaccess_handle();
1687     my $sql = "SELECT last_calc_ts, lc_pass, lc_fail FROM distlookup WHERE distv=?";
1688     my $rows = my_get_query
1689         (
1690          $dbi,
1691          $sql,
1692          $distv
1693         );
1694     if (    defined $rows->[0][0]
1695         and length $rows->[0][0]
1696        ) {
1697         if (     $last_calc_ts eq $rows->[0][0]
1698              and $lc_pass == $rows->[0][1]
1699              and $lc_fail == $rows->[0][2]
1700            ) {
1701             return; # short circuit
1702         } else {
1703             $sql = "UPDATE distlookup SET last_calc_ts=?, lc_pass=?, lc_fail=? WHERE distv=?";
1704             my $success = my_do_query($dbi, $sql, $last_calc_ts, $lc_pass, $lc_fail, $distv);
1705             unless ($success) {
1706                 warn "something went wrong storing lastcalc stuff";
1707             }
1708             return;
1709         }
1710     } else {
1711         warn "something wrong with this record, rows->[0][0] empty";
1712         return;
1713     }
1714 }
1715
1716 =item db_quickaccess_fixup
1717
1718 as of 201401 never reached. Deprecated 201708.
1719
1720 =cut
1721 sub db_quickaccess_fixup {
1722     my($dbi,$distv,$dist) = @_;
1723     die "db_quickaccess_fixup is deprecated";
1724 }
1725
1726 =item cleanup_quick
1727
1728 as of 201401 never reached
1729
1730 =cut
1731 sub cleanup_quick {
1732     my($touched_distv) = @_;
1733     my $slv_dir = sprintf("%s/solved", $workdir);
1734     opendir my $dh, $slv_dir or die "Could not opendir '$slv_dir': $!";
1735     my(%deleted_distv, %fixed_dist);
1736     my $i = 0;
1737     my @readdir = readdir $dh;
1738     warn sprintf "Info: readdir found %d entries in solv_dir[%s]\n", scalar @readdir, $slv_dir;
1739     my $skipped_cleanup_because_touched = 0;
1740  DIRENT: for my $dirent (@readdir) {
1741         next DIRENT if $dirent =~ /\~$/;
1742         $i++;
1743         my($basename,$exte) = $dirent =~ /(.+)\.(yml|slv|slvdv|slvdv\.gz|ts)$/;
1744         warn sprintf
1745             ("DEBUG: %s UTC: checking dirent %d: %s; total deleted: %d",
1746              scalar gmtime,
1747              $i,
1748              $dirent,
1749              scalar keys %deleted_distv,
1750             ) unless $i % 10000;
1751         next DIRENT unless defined $exte;
1752         my $dbi = db_quickaccess_handle();
1753         my $dist = db_quickaccess_select_dist($dbi,$basename);
1754         if ($dist and !$fixed_dist{$dist}++) {
1755             db_quickaccess_fixup($dbi,$basename,$dist);
1756         }
1757         next DIRENT if $exte =~ /^(yml|ts)$/;
1758         if ( $touched_distv->{$basename} ){
1759             $skipped_cleanup_because_touched++;
1760             # we may have to get a fresh context so we can delete
1761             # outdated modules now?
1762             next DIRENT;
1763         }
1764         next DIRENT if $deleted_distv{$basename};
1765         # boring, boring: since we do not delete old stuff in the
1766         # directory, this pretends to delete in quickaccess all
1767         # things already deleted, 15000 distros and growing
1768         #### print "DEBUG: deleting from quickaccess $basename\n";
1769         db_quickaccess_delete($basename);
1770         $deleted_distv{$basename}++;
1771     }
1772     warn "DEBUG: skipped cleanup because touched[$skipped_cleanup_because_touched]";
1773 }
1774
1775 =item megaquery
1776
1777
1778
1779 =cut
1780 sub megaquery {
1781     use IPC::ConcurrencyLimit;
1782     my($basename) = File::Basename::basename(__FILE__);
1783     my $limit = IPC::ConcurrencyLimit->new
1784         (
1785          max_procs => 1,
1786          path      => "$workdir/IPC-ConcurrencyLimit-$basename-megaquery",
1787         );
1788     my $limitid = $limit->get_lock;
1789     while (not $limitid) {
1790         warn "Another process appears to be running a megaquery, sleeping";
1791         sleep 300;
1792         $limitid = $limit->get_lock;
1793     }
1794     my $dbi = mypgdbi();
1795     my $sqlimit = 30_000_000;
1796     my $elasticity = 2000;
1797     if ($Opt{maxfromdb} && $Opt{maxfromdb} < $sqlimit/$elasticity) {
1798         # the $elasticity here is a pure guess that says if we want
1799         # 200 hits, we should read 200*$elasticity records; indeed we
1800         # got 119 record from reading 200000
1801         $sqlimit = $elasticity*$Opt{maxfromdb};
1802     }
1803     # memory bummer:
1804     my $sql = "SELECT id,state,dist,version,fulldate
1805  FROM cpanstats
1806  WHERE type=2 and state='fail'
1807  ORDER BY id DESC LIMIT $sqlimit";
1808     print "Info: about to megaquery ".gmtime()." UTC\n";
1809     my $rows = my_get_query($dbi, $sql);
1810     print "Info: megaquery done ".gmtime()." UTC\n";
1811     return $rows;
1812 }
1813
1814 =item main_enqueuer
1815
1816
1817
1818 =cut
1819 sub main_enqueuer {
1820     my($want_ctgetreport, $touched_distv, $distroquestlabel, $anno, $timetogo,$urgenttimetogo) = @_;
1821  CTG: for my $ctxi (0..$#$want_ctgetreport) {
1822         my $ctx = $want_ctgetreport->[$ctxi];
1823         my($dist,$distv,$version) = @{$ctx}{"dist","distv","version"};
1824         $touched_distv->{$distv}=1;
1825         if ($Opt{pick}) {
1826             my $didit = call_ctgetreports($ctx,1+$ctxi,1+$#$want_ctgetreport);
1827             if ($didit) {
1828                 my $lfh = $didit->{lfh};
1829                 # update the yml, we might have to parse something in the new reports
1830                 my $dbi = mypgdbi();
1831                 $ctx = distroquestion($dbi,1+$ctxi,$distroquestlabel,$dist,$version,$lfh);
1832                 $ctx->{annotation} = $anno->{$distv};
1833                 $ctx->{lastcalc} = $didit->{lc_ts};
1834                 $ctx->{lc_pass} = $didit->{lc_pass};
1835                 $ctx->{lc_fail} = $didit->{lc_fail};
1836                 store_ctx($dbi,$ctx);
1837             }
1838         } else {
1839             enqueue($distv,$#$want_ctgetreport,$ctxi);
1840         }
1841         my $time = time;
1842         my $mustgo = 0;
1843         if ($time > $urgenttimetogo) {
1844             $mustgo = 1;
1845         } elsif ($ctxi == $#$want_ctgetreport){
1846             $mustgo = 1;
1847         } elsif (
1848             1
1849             && $time            >= $timetogo
1850             && $ctxi            >= MUST_CONSIDER
1851            ){
1852             $mustgo  = 1;
1853         }
1854         if ($mustgo) {
1855             my $utc = gmtime($timetogo);
1856             warn "DEBUG: proc[$$]ctxi[$ctxi]timetogo[$timetogo]that is[$utc UTC]";
1857             last CTG;
1858         }
1859     }
1860 }
1861
1862 =item this_urgent
1863
1864 Originally the decision whether a new calc was due was taken by a
1865 random function. We looked at the timestamp of the yaml file and of
1866 the slvfile. Then we read the yaml file and there we concluded on the
1867 upload date. Then we decided how often we want to calc a distro
1868 depending on its age. We mixed some randomness in and said this is
1869 urgent or not. Mostly crap.
1870
1871 Mixing in cpanstats_distrofacts and analysis:distv:calctimestamp?
1872 Especially interested in pass/fail on last calc and pass/fail now.
1873
1874 In cpanstats_distrofacts I see only (for Crypt-Password-0.28)
1875
1876    "db_fails" : 147,
1877    "db_maxid" : 41454838,
1878    "db_maxid_ts" : "2014-04-18T09:29:04.016700Z",
1879    "db_others" : 1,
1880    "db_passes" : 1923,
1881    "thirdfail" : "2012-02-19 02:40z",
1882    "thirdfailid" : "20108048",
1883    "thirdpass" : "2012-02-18 03:29z",
1884    "thirdpassid" : "20078591"
1885
1886 analysis:distv:calctimestamp has only 2500 entries at the moment, so
1887 is not too interesting yet.
1888
1889 Nein, distlookup ist unser Kandidat. Diese pg Tabelle hat
1890
1891  cuti_ts               | timestamp with time zone |
1892  cuti_pass             | integer                  |
1893  cuti_fail             | integer                  |
1894  last_calc_ts          | timestamp with time zone |
1895  lc_pass               | integer                  |
1896  lc_fail               | integer                  |
1897
1898 wobei cuti fuer counted_up_to_id steht. Und wobei last_calc_ts
1899 anscheinend redundant auf analysis:distv:calctimestamp ist.
1900
1901 =cut
1902 sub this_urgent {
1903     my($dbi,$dist,$version,$distv,$anno) = @_;
1904     $distv ||= "$dist-$version";
1905     $anno ||= read_annotations();
1906
1907     $dbi ||= db_quickaccess_handle();
1908     my $sql = "SELECT last_calc_ts, lc_pass, lc_fail, cuti_ts, cuti_pass, cuti_fail
1909                FROM distlookup WHERE distv=?";
1910     my $rows = my_get_query
1911         (
1912          $dbi,
1913          $sql,
1914          $distv
1915         );
1916     my $expensive_type = 0; # 9 huge, 0 not
1917     my $lowactivity = "";
1918     my $maybeexpensive = "";
1919     if (!$rows->[0][4] || !$rows->[0][5]) {
1920         return +{ this_urgent => 0 };
1921     }
1922     unless (grep { ($rows->[0][$_]||0)==0 } 1,2,4,5) {
1923         my($lc_ts,$lc_p,$lc_f,$cnt_ts,$cnt_p,$cnt_f) = @{$rows->[0]};
1924         if ($cnt_p>1.025*$lc_p || $cnt_f>1.025*$lc_f) { # arbitrary
1925             my $lc_total = $lc_p + $lc_f;
1926             if ( $lc_total < 2400 ){
1927                 return +{ this_urgent => 1 }; # activity
1928             } else {
1929                 my($limiting) = min($cnt_p,$cnt_f);
1930                 $maybeexpensive = "over 2400: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1931                 if ( $lc_total/$limiting > 250 ) { # arbitrary
1932                     $expensive_type = 9;
1933                 } else {
1934                     $expensive_type = 5;
1935                 }
1936             }
1937         } elsif ($cnt_p < $lc_p || $cnt_f < $lc_f) { # arbitrary
1938             # we would like to get rid of such brethren; maybe run verify-distlookup-lcpassfail.pl
1939             warn "Sigh, $distv has cnt_p < lc_p || cnt_f < lc_f ($cnt_p < $lc_p || $cnt_f < $lc_f)";
1940             return +{ this_urgent => 0 }; # fix up bad numbers
1941         } elsif ($cnt_p == $lc_p && $cnt_f == $lc_f) {
1942             $lowactivity = "NO growth: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1943         } elsif ($cnt_p < 1.002*$lc_p && $cnt_f < 1.002*$lc_f) { # arbitrary
1944             $lowactivity = "small growth: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1945         }
1946     }
1947
1948     my($csdfacts) = cpanstats_distrofacts($dbi,$dist,$version,$distv,undef);
1949     if (
1950         $csdfacts
1951         && ! $expensive_type
1952         && $csdfacts->{allversions}
1953         && "ARRAY" eq ref $csdfacts->{allversions}
1954         && scalar @{$csdfacts->{allversions}}
1955         && exists $csdfacts->{allversions}[-1]{version}
1956         && $csdfacts->{allversions}[-1]{version} ne $version
1957        ) {
1958         warn "DEBUG: this is urgent: $distv $version ne $csdfacts->{allversions}[-1]{version}";
1959         return +{ this_urgent => 1 };
1960     }
1961     if ($lowactivity) {
1962         return +{ this_urgent => 0, why_not_urgent => $lowactivity };
1963     }
1964
1965     my $averagewait = 86400; # XXX arbitrary: the smaller the more
1966                              # calc; Actually: we use rand to avoid
1967                              # spikes; zero waits and a double of this
1968                              # wait are equally likely
1969
1970     my $minimumwait = 1.9; # XXX arbitrary: the smaller the more calc;
1971                            # Actually: for every year of age of the
1972                            # distro we add this times $averagewait
1973                            # waiting time. Since no age below 1 is
1974                            # possible, this is the minimum wait;
1975                            # setting from 1.7.to 1.8 when the usually
1976                            # set task was 3500 but we only calculated
1977                            # 1000; either we increase the mincalc or
1978                            # reduce the pensum, I would guess;
1979                            # 20160527: taking back to (1.7, 2500),
1980                            # disk gets too full too quickly
1981
1982     if ($maybeexpensive) {
1983         # XXX arbitrary: if we have indications that the calc takes a
1984         # longer time, push back
1985         $minimumwait = $expensive_type >= 6 ? 42 : 15;
1986     }
1987     if ($anno->{$distv} && $minimumwait < 5) {
1988         $minimumwait = 5; # e.g. GFUJI/MouseX-Getopt-0.34.tar.gz
1989     }
1990
1991     my $slv_file = slv_file($distv);
1992     my @slvstat = stat ($slv_file . "dv.gz");
1993     @slvstat = stat $slv_file unless @slvstat;
1994     my $age_of_calc = @slvstat ? time-$slvstat[9] : 999999;
1995
1996     my $yaml = read_ctx($distv);
1997     if ($anno->{$distv}
1998         and (!$yaml->{annotation} || $yaml->{annotation} ne $anno->{$distv})) {
1999         # looks like this annotation has not been stored yet
2000         return +{ this_urgent => 1 };
2001     }
2002     my ($this_urgent, $why_not_urgent) = (0,"");
2003     my $age_in_secs = eval { age_in_secs($yaml->{upload_date}) }; # distro age in secs
2004     if ($@ || !$age_in_secs) {
2005         my $err = $@;
2006         require Carp;
2007         Carp::cluck("WARNING: skipping '$yaml->{distv}' error[$@] upload_date[$yaml->{upload_date}] distv[$distv]");
2008         $this_urgent = 0;
2009         if ($err) {
2010             $why_not_urgent = $err;
2011         } else {
2012             $why_not_urgent = "no upload date";
2013         }
2014         return +{ this_urgent => $this_urgent, why_not_urgent => $why_not_urgent};
2015     }
2016     my $seconds_per_year = 86400*365.25;
2017     my $age_points = $age_in_secs < $seconds_per_year ?
2018         1 : $age_in_secs/$seconds_per_year; # between 1 and 8
2019     my $rand = int(rand(2*$averagewait));
2020     my $rand2 = int($age_points*($rand+$averagewait*$minimumwait));
2021
2022     $this_urgent = $age_of_calc > $rand2; # XXX arbitrary
2023     warn sprintf "DEBUGurg: age_of_calc[%s] age_points[%.3f] rand[%s] rand2[%s] urg[%d]\n",
2024         $age_of_calc, $age_points, $rand, $rand2, $this_urgent;
2025     if (!$this_urgent) {
2026         if (!@slvstat) {
2027             $this_urgent = 1;
2028             warn "DEBUG urg2: urgent because no slvstat"; # never happens
2029         } else {
2030             $why_not_urgent = "age/point calculations";
2031         }
2032     }
2033     return +{ this_urgent => $this_urgent, why_not_urgent => $why_not_urgent};
2034 }
2035
2036 my($timetogo,$urgenttimetogo);
2037 {
2038     $timetogo       = $^T + ($Opt{mincalctime} || MIN_CALCTIME);
2039     $urgenttimetogo = MAX_CALCTIME + $^T;
2040 }
2041 MAIN: {
2042     my $mainentrytime = time;
2043     my $solved = [];
2044     my $anno = {};
2045     if ($Opt{onlystartwhennojobs}) {
2046         my $redis = myredis;
2047     WAITNOQ: while () {
2048             my($zcard) = $redis->zcard("analysis:jobqueue:q");
2049             last WAITNOQ if $zcard == 0;
2050             sleep 60;
2051         }
2052     }
2053     if ($Opt{pick}) {
2054         warn "saw --pick=$Opt{pick}, skipping readdir on solved/ directory";
2055         my $shadow_anno = read_annotations();
2056         if (exists $shadow_anno->{$Opt{pick}}) {
2057             $anno->{$Opt{pick}} = $shadow_anno->{$Opt{pick}};
2058         }
2059     } else {
2060         $anno = read_annotations();
2061         unless (defined $Opt{maxfromsolved} && 0 == $Opt{maxfromsolved}) {
2062             # looks in workdir/solved/ where we find eg. a2pdf-1.13.{slv,slvdv,yml}
2063             $solved = CPAN::Blame::Model::Solved->all("readdir");
2064         }
2065     }
2066     my(%seen,@want_ctgetreport);
2067     # revisit all our friends first
2068     my $touched_distv = {};
2069  ANNO_SOLVED: for my $set
2070         (
2071          {name => "anno", data => $anno}, # anno is a hashref
2072          {name => "solved", data => $solved}, # solved is an arrayref
2073         ) {
2074         my @k; # names like "a2pdf-1.13"
2075         my $urgent = $Opt{urgent} || 0;
2076         if (0) {
2077         } elsif ($Opt{pick}) {
2078             # pick trumps, the others don't play when we are a worker
2079             @k = $Opt{pick};
2080         } elsif ($set->{name} eq "anno") {
2081             @k = keys %{$set->{data}};
2082             if (defined $Opt{maxfromannotate}) {
2083                 pop @k while @k > $Opt{maxfromannotate};
2084             }
2085         } elsif ($set->{name} eq "solved") {
2086             @k = map { $_->{distv} } @{$set->{data}};
2087             if (defined $Opt{maxfromsolved}) {
2088                 pop @k while @k > $Opt{maxfromsolved};
2089             }
2090         } else {
2091             die;
2092         }
2093         my $distroquestlabel = substr($set->{name},0,4) . "-" . scalar @k; # gives a bit of orientation in the runlog
2094         my $i = 0;
2095     DISTV: for my $k (@k) {
2096             $touched_distv->{$k}=1;
2097             my $d = CPAN::DistnameInfo->new("FOO/$k.tgz");
2098             my $dist = $d->dist;
2099             my $version = $d->version;
2100             ++$i;
2101             next DISTV if $seen{$dist,$version}++;
2102             my($this_urgent, $why_not_urgent);
2103             my $slv_file = slv_file($k);
2104             if ($urgent) {
2105                 $this_urgent = 1;
2106             } elsif (! -e ($slv_file."dv.gz") && ! -e ($slv_file."dv")) {
2107                 $this_urgent = 1;
2108             } elsif ($Opt{pick}) {
2109                 $this_urgent = 1;
2110             } else {
2111                 my $href = this_urgent(undef,$dist,$version,$k,$anno);
2112                 ($this_urgent, $why_not_urgent) = @{$href}{qw(this_urgent why_not_urgent)};
2113             }
2114             unless ($this_urgent){
2115                 printf "Warning: skipping %s (%s)\n", $k, $why_not_urgent;
2116                 next DISTV;
2117             }
2118             my $pgdbi = mypgdbi();
2119             my $ctx = distroquestion($pgdbi,$i,$distroquestlabel,$dist,$version,undef) or next;
2120             $ctx->{annotation} = $anno->{$k};
2121             store_ctx($pgdbi,$ctx);
2122             push @want_ctgetreport, $ctx;
2123         }
2124     } # ANNO_SOLVED
2125     my $rows = [];
2126     if ($Opt{pick}) {
2127     } else {
2128         unless (defined $Opt{maxfromdb} && 0==$Opt{maxfromdb}) {
2129             $rows = megaquery();
2130         }
2131     }
2132     my $skip_random = 0;
2133     my $i = 0;
2134     my $mindate;
2135     {
2136         my @now = gmtime;
2137         $now[4]++;
2138         $now[5]+=1900;
2139         $mindate = sprintf "%04d%02d%02d%02d%02d", $now[5]-$CPAN::Blame::Config::Cnntp::Config->{maxyears}, @now[reverse 1..4];
2140     }
2141     warn sprintf
2142         (
2143          "DEBUG: before going through megaquery result: array want_ctgetreport[%d] rows from megaquery[%d]\n",
2144          scalar @want_ctgetreport,
2145          scalar @$rows,
2146         );
2147     my $distroquestlabel = "B" . scalar @$rows;
2148     my $why_last_article = "";
2149  ARTICLE: while (my $row = shift @$rows) {
2150         sleep 0.3;
2151         my($id,$state,$dist,$version,$date) = @$row;
2152         unless ($id){
2153             $why_last_article = "no id in row[@$row]";
2154             last ARTICLE;
2155         }
2156         if ($date lt $mindate){
2157             $why_last_article = "date[$date] lt mindate[$mindate] i[$i]";
2158             last ARTICLE;
2159         }
2160         next ARTICLE unless defined $dist and defined $version;
2161         if ($seen{$dist,$version}++){
2162             $why_last_article = "last action was skipping $dist,$version (reaching last ARTICLE via next)";
2163             next ARTICLE;
2164         }
2165         # note: when we arrive here. We will display current $i in the leftmost column as in
2166         # 170 B2801844 13-10-29 147: 21:  0 KSTAR/Dancer-Plugin-DynamicConfig-0.04 (<0.07)
2167         $i++;
2168         if ($Opt{maxfromdb} && $i > $Opt{maxfromdb}) {
2169             last ARTICLE;
2170         }
2171         my $pgdbi = mypgdbi();
2172         my $ctx = distroquestion($pgdbi,$i,$distroquestlabel,$dist,$version,undef) or next;
2173         $ctx->{annotation} = $anno->{$ctx->{distv}};
2174         store_ctx($pgdbi,$ctx);
2175         if ($ctx->{greenish} && $ctx->{greenish} >= 3) {
2176             push @want_ctgetreport, $ctx;
2177         }
2178         if ($i >= 487) { # XXX arbitrary
2179             if ($skip_random) {
2180                 # note: in 2013 we never reached 800, we reached the 8
2181                 # year old distros before that, yesterday at $i==666,
2182                 # and want_ctgetreport had 3823 entries
2183                 if ($i >= 1200 && @want_ctgetreport >= 200) { # XXX arbitrary
2184                     $why_last_article = "i[$i] > xxx and want_ctgetreport > 150";
2185                     last ARTICLE;
2186                 } elsif ($i >= 800 && @want_ctgetreport >= 300) { # XXX arbitrary
2187                     $why_last_article = "i[$i] > xxx and want_ctgetreport > 200";
2188                     last ARTICLE;
2189                 }
2190             } else {
2191                 printf "Debug: switching to skip_random mode\n";
2192                 $skip_random = 1;
2193             }
2194         }
2195         if ($skip_random) {
2196             # compensate for the fact that we do not have and do not
2197             # even want to provide the computing power to calculate
2198             # all possible regressions simultaneously; yes, we are a
2199             # bit sloppy but do not believe anybody will notice; some
2200             # day we may want to stop this program to go into the
2201             # oldest data in the database because it will become
2202             # worthless; then we probably want to make sure all data
2203             # in a certain range get processed exactly once.
2204             my $skip = int rand 40000; # XXX arbitrary
2205             splice @$rows, 0, $skip;
2206         }
2207         sleep 0.1;
2208         $why_last_article = "simply reached end of loop";
2209     }
2210     warn sprintf "DEBUG: Reached last ARTICLE why?[%s] array want_ctgetreport[%d]", $why_last_article, scalar @want_ctgetreport;
2211     @want_ctgetreport = sort
2212         {
2213             # Wishlist: first sort criterium should be in favor of
2214             # those who have no calc yet at all. But then we might
2215             # schedule them too early because cpantesters are behind
2216             # log.txt
2217             ($b->{upload_date}||"") cmp ($a->{upload_date}||"")
2218             ||
2219             ($a->{distro_age}||0) <=> ($b->{distro_age}||0)
2220             ||
2221             $a <=> $b # crap, just the address because there is nothing better in sight
2222         } @want_ctgetreport;
2223     $distroquestlabel = "ctg-" . scalar @want_ctgetreport;
2224     main_enqueuer(\@want_ctgetreport, $touched_distv, $distroquestlabel, $anno, $timetogo,$urgenttimetogo);
2225     if ($Opt{pick}) {
2226         warn "nothing will be deleted, we're on a picking trip";
2227     } else {
2228         # XXX temporarily disabling cleanup_quick on 2014-01-01;
2229         # because we do not understand the exact implications of the
2230         # queuing system; but this for sure must be re-examined.
2231         #### cleanup_quick($touched_distv);
2232     WAITTOGO: while (time < $timetogo) {
2233             if ($Opt{leavewhennojobsleft}) {
2234                 my $redis = myredis;
2235                 my($zcard) = $redis->zcard("analysis:jobqueue:q");
2236                 last WAITTOGO if $zcard == 0;
2237             }
2238             sleep 60;
2239         }
2240     }
2241 }
2242
2243
2244 1;
2245
2246 __END__
2247
2248 =back
2249
2250 =head1 BUGS
2251
2252 TRIAL?
2253
2254 Too slow update cycle
2255
2256 Often does not recognize when a newer version is available, maybe only
2257 when the newer version is all-green or so?
2258
2259 Sqlite
2260
2261 =head1 HISTORICAL NOTES
2262
2263 show the most recent FAILs on cpantesters. Compare to annotations.txt
2264 which I maintain manually in annotations.txt. Roughly the job is
2265 organized as (1) update the database syncing with cpantesters, (2)
2266 process (2.1) annotations, (2.2) previously solved regressions, (2.3)
2267 database to schedule some 1000 batchjob-candidates with (2.3.1) is the
2268 megaquery and (2.3.2) steps through it. (3) Run these batchjobs, many
2269 of which are being skipped. (4) delete several thousand outdated files
2270 and/or directories. Timings on 2013-10-29 and -30
2271
2272   |         | 20131029 | 20131127 |
2273   |---------+----------+----------|
2274   | (1)     | 06:30:09 |          |
2275   | (2.1)   | 10:54:22 | 10:28:49 |
2276   | (2.2)   | 15:15:43 | 11:09:37 |
2277   | (2.3.1) | 20:41:42 | 13:26:49 |
2278   | (2.3.2) | 21:08:51 | 13:29:02 |
2279   | (3)     | 22:53:15 | 14:29:28 |
2280   | (4)     | 16:44:07 |          |
2281   | (T)     | 16:45:00 |          |
2282
2283 The schema of cpanstats.db once was considered to be
2284
2285   0 | id       | 5379605                         |5430514
2286   1 | state    | pass                            |fail
2287   2 | postdate | 200909                          |
2288   3 | tester   | bingos@cpan.org                 |
2289   4 | dist     | Yahoo-Photos                    |Apache-Admin-Config
2290   5 | version  | 0.0.2                           |0.94
2291   6 | platform | i386-freebsd-thread-multi-64int |i386-freebsd
2292   7 | perl     | 5.10.0                          |
2293   8 | osname   | freebsd                         |
2294   9 | osvers   | 7.2-release                     |7.2-release
2295  10 | date     | 200909190440                    |200909190440
2296
2297 but has changed to
2298
2299    id            INTEGER PRIMARY KEY, -- 1
2300    state         TEXT,                -- 2
2301    postdate      TEXT,                -- 3
2302    tester        TEXT,                -- 4
2303    dist          TEXT,                -- 5
2304    version       TEXT,                -- 6
2305    platform      TEXT,                -- 7
2306    perl          TEXT,                -- 8
2307    osname        TEXT,                -- 9
2308    osvers        TEXT,                -- 10
2309    date          TEXT,                -- 11
2310    guid          char(36) DEFAULT '', -- 12
2311    type          int(2) default 0)    -- 13
2312
2313 guid and type are new. guid replaces id but is in a different format. schema is generated by
2314
2315   Revision history for Perl module CPAN::Testers::Data::Generator.
2316
2317   0.41    18/03/2010
2318           - fixes to change the 'id' (was NNTP ID) to an auto incremental field.
2319           - reworked logic to better fit latest changes.
2320           - added repository to META.yml.
2321           - documentation updates.
2322
2323   0.40    02/02/2010
2324           - fixes to accommodate GUID changes.
2325           - added support for 'type' field.
2326
2327 From reading the source, type seems to be 0 or 2 for valid records. 1
2328 is for pause announcements and 3 is for disabled reports. IIUC 0 is
2329 for old records and 2 for new ones. That would mean that there is a
2330 constant number of records with type==0?
2331
2332 A few months ago we counted:
2333
2334   sqlite> select type,count(*) from cpanstats group by type;
2335   0|1570
2336   1|123723
2337   2|6899753
2338   3|15131
2339
2340 and today:
2341
2342   sqlite> select type,count(*) from cpanstats group by type;
2343   0|1570
2344   1|130858
2345   2|7745256
2346   3|15131
2347
2348 So we can rely on having to read only type==2 from now on.
2349
2350 But before we can do anything we must
2351 s/CPAN::WWW::Testers::Generator::Database/CPAN::Testers::Data::Generator/g; or
2352 something equivalent.
2353
2354 I see no reason why I should make use of the guid except maybe for
2355 links to cpantesters. Internal stuff should work with id just like it
2356 always did.
2357
2358 Update 2011-10-12 andk: schema change again, new schema is:
2359
2360    id          INTEGER PRIMARY KEY,    -- 1
2361    guid        TEXT,                   -- 12
2362    state       TEXT,                   -- 2
2363    postdate    TEXT,                   -- 3
2364    tester      TEXT,                   -- 4
2365    dist        TEXT,                   -- 5
2366    version     TEXT,                   -- 6
2367    platform    TEXT,                   -- 7
2368    perl        TEXT,                   -- 8
2369    osname      TEXT,                   -- 9
2370    osvers      TEXT,                   -- 10
2371    fulldate    TEXT,                   -- is new, probably was date (11)
2372    type        INTEGER                 -- 13
2373
2374
2375
2376 =head1 TODO
2377
2378 open tickets?
2379