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 form 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:'Out of memory\\!'}
1254              .qq{ --q qr:'Prototype mismatch:'}
1255              .qq{ --q qr:'Connection reset by peer'}
1256              .qq{ --q qr:'depends on targets in skipped section'}
1257              .qq{ --q qr:'Network error'}
1258              .qq{ --q qr:'Insecure .+ while running with'}
1259              .qq{ --q qr:'must be adjacent in regex'}
1260              .qq{ --q qr:'locate object method .new. via package .Test2::Context.'}
1261              .qq{ --q qr:'Use of code point 0x[[:xdigit:]]+ is deprecated; the permissible max is 0x7FFFFFFF'}
1262              .qq{ --q qr:'# (.+ but done_testing.+ expects .+)'}
1263              .$addctgargs
1264              .qq{ --solve --solvetop=123$sample_argument}
1265              .qq{ --dumpfile=$dumpfile}
1266              .qq{ --minpass=3}
1267              .qq{ --transport=http_cpantesters_gzip}
1268              .qq{ --prefer-local-reports}
1269              .qq{ --vdistro=$distv $ctx->{dist} > $slv_file.new 2>&1}
1270              .q{ --filtercb='my $r = shift; $r->{"meta:ok"} = "FILTERED" if $r->{"qr:locate object method .new. via package .Test2::Context."}'}
1271              .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"}'}
1272              .q{ --filtercb='my $r = shift; for (split " ", $r->{"conf:ccflags"}){$r->{"conf:ccflags~$_"} = 1}'}
1273             );
1274         warn "Info: running system[$system]";
1275         my $ret = process_ctg($system, $distv);
1276         # gzip: /home/ftp/cnntp-solver-2009/workdir/solved/Dist-Zilla-Plugin-Twitter-0.015-TRIAL.slvdv: No such file or directory
1277         my $redis = myredis;
1278         $redis->zrem("analysis:distv:eta",$distv);
1279         if ($ret==0) {
1280             unless (0 == system "gzip -9f $dumpfile") {
1281                 warn "Warning: error while running gzip on '$dumpfile', continuing...";
1282                 return;
1283             }
1284             unless (0 == system
1285                     qq{tar -C "$hashed_ctg_parent" --remo -cf "$hashed_ctg_parent/$distv.tar" "$distv"}) {
1286                 warn "Warning: error while running tar cf on '$distv', continuing...";
1287                 return;
1288             }
1289             my @stat = stat "$dumpfile.gz";
1290             $redis->zadd("analysis:distv:calctimestamp",$stat[9],$distv) if @stat;
1291             my $lc_ts = Time::Moment->from_epoch($stat[9])->to_string; # lc=last calc
1292             open my $zfh, "-|", "zcat", "$dumpfile.gz" or die "could not fork: $!";
1293             my $j = do {local $/; <$zfh>};
1294             use JSON::XS;
1295             my $h = JSON::XS->new->decode($j);
1296             my %passfail = map { $_ => $h->{"meta:ok"}{$_}{$_} } qw(PASS FAIL);
1297             for my $pf (qw(pass fail)) {
1298                 my $redis_key = "analysis:distv:lc$pf"; # analysis:distv:lcpass
1299                 my $pf_value = $passfail{uc $pf} // 0;  # $passfail{PASS}
1300                 $redis->zadd($redis_key, $pf_value, $distv);
1301             }
1302             rename "$slv_file.new", $slv_file or die "Could not rename: $!";
1303             mytouch("slv",{name => $distv});
1304             return {
1305                     lfh => $lfh,
1306                     lc_ts => $lc_ts,
1307                     lc_pass => $passfail{PASS}//0,
1308                     lc_fail => $passfail{FAIL}//0,
1309                    }; # did it!
1310         } else {
1311             warn "Alert: Error running ctgetreports; command was [$system]";
1312             return;
1313         }
1314     } else {
1315         return;
1316     }
1317 }
1318
1319 {
1320     my($old_highscore);
1321     sub enqueue {
1322         my($distv,$want_ctgetreport,$ctxi) = @_;
1323         if ($distv eq "libxml-enno-1.02") {
1324             require Carp;
1325             Carp::cluck("$distv is generally unwanted, go away.");
1326             sleep 60;
1327             return;
1328         }
1329         my $redis = myredis;
1330         unless (defined $old_highscore) {
1331             my($topdistv,$highscore) = $redis->zrevrange("analysis:jobqueue:q",0,0,"withscores");
1332             $old_highscore = $highscore;
1333             $old_highscore //= 0;
1334         }
1335         my($thisscore) = $redis->zscore("analysis:jobqueue:q",$distv);
1336         $thisscore //= 0;
1337         my $score = $want_ctgetreport - $ctxi; # linear decreasing
1338         if ($ctxi < 40 && $old_highscore > $score) {
1339             # the first 40 deserve a better score than the old ones
1340             $score = $old_highscore + 40 - $ctxi;
1341         }
1342         if ($score<=0) {
1343             $score = 1;
1344         }
1345         if ($thisscore >= $score) {
1346             # nothing to do
1347             return;
1348         }
1349         my $debug = 1;
1350         if ($debug) {
1351             my($zcard) = $redis->zcard("analysis:jobqueue:q");
1352             warn "DEBUG: enqueueing ctxi[$ctxi] old_highscore[$old_highscore] score[$score] distv[$distv] zcard[$zcard]\n";
1353         }
1354         $redis->zadd("analysis:jobqueue:q", $score, $distv);
1355     }
1356 }
1357
1358 =item process_ctg
1359
1360 Runs a ctgetreports job with all of our redis interaction
1361
1362 Revisited 2015-04-06: looks wrong to me. But remember, we have redis
1363 1.2 on our ds8143 and that did not even have a hash. That's for
1364 example why we used JSON::XS here, we could have used hash instead.
1365 But I'm sure that the "pattern" that I was reading in the Redis
1366 documentation at that time has changed significantly since then. Maybe
1367 we should rewrite the code according to the current description.
1368
1369 =cut
1370 sub process_ctg {
1371     my($system, $distv) = @_;
1372     my $start = time;
1373     my $redis = myredis;
1374     my $jsonxs = JSON::XS->new->indent(0);
1375     my $job_object = {distv=>$distv,start=>$start};
1376     my $json = $jsonxs->encode($job_object);
1377     my $sha1 = Digest::SHA->new(1);
1378     $sha1->add($json);
1379     my $hex = $sha1->hexdigest;
1380     my $id = $redis->get("analysis:jobqueue:jobs:$hex\:id");
1381     unless ($id) {
1382         my($nid) = $redis->incr("analysis:jobqueue:next.job.id");
1383         if (my($setnx) = $redis->setnx("analysis:jobqueue:jobs:$hex\:id" => $nid)) {
1384             $id = $nid;
1385         } else {
1386             warn "WARNING: Should never happen, it would mean that two jobs calc the same thing at the same time. json[$json]hex[$hex]";
1387             $id = $redis->get("analysis:jobqueue:jobs:$hex\:id");
1388         }
1389     }
1390     $redis->set("analysis:jobqueue:jobs:$id\:descr" => $json); # will set again afterwards
1391     $redis->set("analysis:jobqueue:jobs:$id\:hex" => $hex);
1392     $redis->sadd("analysis:jobqueue:runningjobs" => $id); # must srem
1393     my $ret = system $system;
1394     my $finished = time;
1395     my $took = $finished - $start;
1396     $job_object->{finished} = $finished;
1397     $job_object->{took} = $took;
1398     $job_object->{ret} = $ret;
1399     $json = $jsonxs->encode($job_object);
1400     $redis->set("analysis:jobqueue:jobs:$id\:descr" => $json); # setting again
1401     $redis->srem("analysis:jobqueue:runningjobs" => $id); # as promised
1402     $redis->rpush("analysis:jobqueue:recentjobs" => $id);
1403     while ($redis->llen("analysis:jobqueue:recentjobs") > 10000) {
1404         my($del_id) = $redis->lpop("analysis:jobqueue:recentjobs");
1405         my($del_hex) = $redis->get("analysis:jobqueue:jobs:$del_id\:hex");
1406         $redis->del("analysis:jobqueue:jobs:$del_hex\:id");
1407         $redis->del("analysis:jobqueue:jobs:$del_id\:descr");
1408         $redis->del("analysis:jobqueue:jobs:$del_id\:hex");
1409     }
1410     if ($took > 3600) {
1411         warn "Warning: slow calc on '$distv'; took[$took]";
1412     }
1413     return $ret;
1414 }
1415
1416 =item read_ctx
1417
1418 Reads the context of this distv from the yaml file
1419
1420 =cut
1421 sub read_ctx {
1422     my($distv) = @_;
1423     my $outfile = sprintf "%s/solved/%s.yml", $workdir, $distv;
1424     my @stat = stat $outfile or return;
1425     YAML::Syck::LoadFile($outfile);
1426 }
1427
1428 =item store_ctx ($dbi,$ctx)
1429
1430 $dbi may be undef. (For the record, we often have no dbi handle
1431 around, but if we have one, we want to pass it around. This has its
1432 historical reason in sqlite's misbehaving when faced with concurrent
1433 accesses. So we tried to keep the lifespan of dbi handles as short as
1434 possible.)
1435
1436 Checks the hashref $ctx against the yaml file on disk, writes it if
1437 something has changed. Then writes it also to the database. If this is
1438 a first-time encounter and greenish is >= 3, it is also enqueued for a
1439 first calc.
1440
1441 =cut
1442 sub store_ctx {
1443     my($dbi,$ctx) = @_;
1444     my $outfile = sprintf "%s/solved/%s.yml", $workdir, $ctx->{distv};
1445     my @stat = stat $outfile;
1446     my $want_write = 0;
1447     my $want_enqueue = 0;
1448     {
1449         my $reduced_ctx = dclone $ctx;
1450         delete $reduced_ctx->{distro_age};
1451         my $curr_dump = YAML::Syck::Dump($reduced_ctx);
1452         if (@stat) {
1453             my $last_dump = do
1454                 { open my $fh, $outfile or die "Could not open '$outfile': $!";
1455                   local $/;
1456                   <$fh>;
1457               };
1458             $want_write = $curr_dump ne $last_dump;
1459             no warnings 'uninitialized';
1460             if ($want_write and $ctx->{lastcalc} and $ctx->{passfail_overview}) {
1461                 my $old_ctx = YAML::Syck::Load($last_dump);
1462                 if ($ctx->{lastcalc} ne $old_ctx->{lastcalc}) {
1463                     # distlookup: last_calc_ts, lc_pass, lc_fail
1464                     db_store_lastcalc(
1465                         $dbi,
1466                         $ctx->{distv},
1467                         $ctx->{lastcalc},
1468                         $ctx->{lc_pass},
1469                         $ctx->{lc_fail},
1470                     );
1471                 }
1472             }
1473         } else {
1474             $want_write = 1;
1475             if ($ctx->{greenish} && $ctx->{greenish} >= 3) {
1476                 $want_enqueue = 1;
1477             }
1478         }
1479         if ($want_write) {
1480             mkpath dirname $outfile;
1481             open my $fh, ">", "$outfile.new" or die "Could not open > '$outfile.new': $!";
1482             print $fh $curr_dump;
1483             close $fh or die "Could not close: $!";
1484             rename "$outfile.new", $outfile or die "Could not rename: $!";
1485         }
1486         db_quickaccess_insert_or_update
1487             (
1488              undef,
1489              $ctx->{distv},
1490              $curr_dump,
1491              $ctx->{greenish},
1492              $ctx->{dist},
1493             );
1494     }
1495     if ($want_enqueue) {
1496         enqueue($ctx->{distv},0,1);
1497     }
1498     mytouch("yml",{name => $ctx->{distv}});
1499 }
1500
1501 =item db_quickaccess_handle
1502
1503
1504
1505 =cut
1506 sub db_quickaccess_handle {
1507     return CPAN::Blame::Config::Cnntp::common_quickaccess_handle();
1508 }
1509
1510 =item db_quickaccess_insert_or_update
1511
1512 Convenience function for getting stuff into distcontext table. You
1513 cannot set anything to null here, only to some value. Any value given
1514 as undef is skipped in the generated update statement. Against common
1515 best practice, this code first looks whether a record exists and only
1516 does an insert if it does not exist. We believe this is OK since we
1517 never want to delete records here.
1518
1519 Besides that, this function does nothing when the caller would not
1520 change anything.
1521
1522 =cut
1523 sub db_quickaccess_insert_or_update {
1524     my($dbi,$distv,$yaml,$greenish,$dist) = @_;
1525     $dbi ||= db_quickaccess_handle();
1526     my $sql = "SELECT yaml,greenish,dist FROM distcontext WHERE distv=?";
1527     my $rows = my_get_query
1528         (
1529          $dbi,
1530          $sql,
1531          $distv
1532         );
1533     if (!@$rows) {
1534         $sql = "INSERT INTO distcontext (distv) VALUES (?)";
1535         my_do_query
1536             (
1537              $dbi,
1538              $sql,
1539              $distv
1540             );
1541     }
1542     no warnings 'uninitialized';
1543     my(%othersets) = (yaml => $yaml, greenish => $greenish, dist => $dist);
1544     my(%oldvalues) =
1545         (
1546          yaml     => $rows->[0][0],
1547          greenish => $rows->[0][1],
1548          dist     => $rows->[0][2],
1549         );
1550     my(@set, @bind);
1551     while (my($k,$v) = each %othersets) {
1552         if (defined $v && $v ne $oldvalues{$k}) {
1553             push @set, "$k=?";
1554             push @bind, $v;
1555         }
1556     }
1557     return unless @bind;
1558     push @bind, $distv;
1559     # $sql = "UPDATE distcontext SET yaml=?, greenish=?, dist=? WHERE distv=?";
1560     $sql = sprintf "UPDATE distcontext SET %s WHERE distv=?", join(", ", @set);
1561     warn "DEBUG: sql[$sql] bind[@bind]";
1562     my_do_query($dbi, $sql, @bind);
1563 }
1564
1565 =item db_quickaccess_delete
1566
1567 forbidden call, because we believe that we want to keep distv=>dist
1568 relation here forever and in any case. We use that relation in
1569 allversions stuff.
1570
1571 =cut
1572 sub db_quickaccess_delete {
1573     my($distv) = @_;
1574     require Carp;
1575     Carp::confess("somebody called db_quickaccess_delete");
1576     my $dbi = db_quickaccess_handle();
1577     my $sql = "DELETE FROM distcontext WHERE distv=?";
1578     my_do_query
1579         (
1580          $dbi,
1581          $sql,
1582          $distv
1583         );
1584 }
1585
1586 =item mytouch
1587
1588
1589 =cut
1590 sub mytouch ($$) {
1591     my($type,$message) = @_;
1592     my $file = sprintf "%s/solved/lastchange_%s.ts", $workdir, $type;
1593     open my $fh, ">", $file or die "Could not open >'$file': $!";
1594     print $fh YAML::Syck::Dump($message);
1595     close $fh or die "Could not close '$file': $!";
1596 }
1597
1598 =item age_in_secs
1599
1600
1601
1602 =cut
1603 sub age_in_secs {
1604     my($iso) = @_;
1605     my @date = unpack "a4 a1 a2 a1 a2", $iso; # 2006-07-04
1606     $date[2]--; # make month zero-based
1607     my $epoch = eval {  timegm(0,0,0,@date[4,2,0]);  };
1608     if ($@ || !$epoch) {
1609         require Carp;
1610         Carp::confess("ALERT: date[@date] iso[$iso]");
1611     }
1612     time - $epoch;
1613 }
1614
1615 =item db_quickaccess_select_dist
1616
1617
1618
1619 =cut
1620 sub db_quickaccess_select_dist {
1621     my($dbi,$distv) = @_;
1622     my $sql = "SELECT dist FROM distcontext WHERE distv=?";
1623     my $rows = my_get_query
1624         (
1625          $dbi,
1626          $sql,
1627          $distv
1628         );
1629     return unless @$rows>0;
1630     return $rows->[0][0];
1631 }
1632
1633 =item db_fixup_release_date
1634
1635 Fetch a release date from metacpan and write it into
1636 release_date_metacpan in distlookup. Dies if the field is not empty.
1637
1638 =cut
1639 sub db_fixup_release_date {
1640     my($dbi,$dist,$version,$distv) = @_;
1641     $dbi ||= db_quickaccess_handle();
1642     $distv ||= "$dist-$version";
1643     my $sql = "SELECT release_date_metacpan FROM distlookup WHERE distv=?";
1644     my $rows = my_get_query
1645         (
1646          $dbi,
1647          $sql,
1648          $distv
1649         );
1650     if (defined $rows->[0][0] and length $rows->[0][0]) {
1651         die "Alert: found record for distv '$distv' where release_date_metacpan is '$rows->[0][0]'";
1652     }
1653     my $ua = LWP::UserAgent->new(agent => "analysis.cpantesters.org/$VERSION");
1654     $ua->default_header("Accept-Encoding", "gzip");
1655     my $jsonxs = JSON::XS->new->indent(0);
1656     # my $query = "http://api.metacpan.org/v0/release/_search?q=release.name:$distv&fields=name,date,status";
1657     my $query = "http://fastapi.metacpan.org/v1/release/_search?q=name:$distv&fields=name,date,status";
1658     my $resp = $ua->get($query);
1659     my $date;
1660     if ($resp->is_success) {
1661         my $content = $resp->decoded_content;
1662         my $mcpananswer = $jsonxs->decode($content);
1663         if (my $h = $mcpananswer->{hits}{hits}) {
1664             $date = $h->[0]{fields}{date};
1665         } else {
1666             warn sprintf "Warning: result from metacpan api has no hits: %s\n", $content;
1667         }
1668     } else {
1669         die sprintf "No success getting from metacpan: query '%s' response '%s'", $query, $resp->as_string;
1670     }
1671     warn sprintf "DEBUG: rows[%d] distv[%s] dist[%s] date[%s]\n", scalar @$rows, $distv, $dist, $date;
1672     $sql = "UPDATE distlookup set release_date_metacpan=? WHERE distv=?";
1673     my $success = my_do_query($dbi,$sql,$date,$distv);
1674     return
1675         +{
1676           success => $success,
1677          };
1678 }
1679
1680 =item (void) db_store_lastcalc ($dbi, $distv, $last_calc_ts, $lc_pass, $lc_fail)
1681
1682 Stores the last calc's coordinates. Short-circuits if they are already there.
1683
1684 =cut
1685 sub db_store_lastcalc {
1686     my($dbi, $distv, $last_calc_ts, $lc_pass, $lc_fail) = @_;
1687     $dbi ||= db_quickaccess_handle();
1688     my $sql = "SELECT last_calc_ts, lc_pass, lc_fail FROM distlookup WHERE distv=?";
1689     my $rows = my_get_query
1690         (
1691          $dbi,
1692          $sql,
1693          $distv
1694         );
1695     if (    defined $rows->[0][0]
1696         and length $rows->[0][0]
1697        ) {
1698         if (     $last_calc_ts eq $rows->[0][0]
1699              and $lc_pass == $rows->[0][1]
1700              and $lc_fail == $rows->[0][2]
1701            ) {
1702             return; # short circuit
1703         } else {
1704             $sql = "UPDATE distlookup SET last_calc_ts=?, lc_pass=?, lc_fail=? WHERE distv=?";
1705             my $success = my_do_query($dbi, $sql, $last_calc_ts, $lc_pass, $lc_fail, $distv);
1706             unless ($success) {
1707                 warn "something went wrong storing lastcalc stuff";
1708             }
1709             return;
1710         }
1711     } else {
1712         warn "something wrong with this record, rows->[0][0] empty";
1713         return;
1714     }
1715 }
1716
1717 =item db_quickaccess_fixup
1718
1719 as of 201401 never reached. Deprecated 201708.
1720
1721 =cut
1722 sub db_quickaccess_fixup {
1723     my($dbi,$distv,$dist) = @_;
1724     die "db_quickaccess_fixup is deprecated";
1725 }
1726
1727 =item cleanup_quick
1728
1729 as of 201401 never reached
1730
1731 =cut
1732 sub cleanup_quick {
1733     my($touched_distv) = @_;
1734     my $slv_dir = sprintf("%s/solved", $workdir);
1735     opendir my $dh, $slv_dir or die "Could not opendir '$slv_dir': $!";
1736     my(%deleted_distv, %fixed_dist);
1737     my $i = 0;
1738     my @readdir = readdir $dh;
1739     warn sprintf "Info: readdir found %d entries in solv_dir[%s]\n", scalar @readdir, $slv_dir;
1740     my $skipped_cleanup_because_touched = 0;
1741  DIRENT: for my $dirent (@readdir) {
1742         next DIRENT if $dirent =~ /\~$/;
1743         $i++;
1744         my($basename,$exte) = $dirent =~ /(.+)\.(yml|slv|slvdv|slvdv\.gz|ts)$/;
1745         warn sprintf
1746             ("DEBUG: %s UTC: checking dirent %d: %s; total deleted: %d",
1747              scalar gmtime,
1748              $i,
1749              $dirent,
1750              scalar keys %deleted_distv,
1751             ) unless $i % 10000;
1752         next DIRENT unless defined $exte;
1753         my $dbi = db_quickaccess_handle();
1754         my $dist = db_quickaccess_select_dist($dbi,$basename);
1755         if ($dist and !$fixed_dist{$dist}++) {
1756             db_quickaccess_fixup($dbi,$basename,$dist);
1757         }
1758         next DIRENT if $exte =~ /^(yml|ts)$/;
1759         if ( $touched_distv->{$basename} ){
1760             $skipped_cleanup_because_touched++;
1761             # we may have to get a fresh context so we can delete
1762             # outdated modules now?
1763             next DIRENT;
1764         }
1765         next DIRENT if $deleted_distv{$basename};
1766         # boring, boring: since we do not delete old stuff in the
1767         # directory, this pretends to delete in quickaccess all
1768         # things already deleted, 15000 distros and growing
1769         #### print "DEBUG: deleting from quickaccess $basename\n";
1770         db_quickaccess_delete($basename);
1771         $deleted_distv{$basename}++;
1772     }
1773     warn "DEBUG: skipped cleanup because touched[$skipped_cleanup_because_touched]";
1774 }
1775
1776 =item megaquery
1777
1778
1779
1780 =cut
1781 sub megaquery {
1782     use IPC::ConcurrencyLimit;
1783     my($basename) = File::Basename::basename(__FILE__);
1784     my $limit = IPC::ConcurrencyLimit->new
1785         (
1786          max_procs => 1,
1787          path      => "$workdir/IPC-ConcurrencyLimit-$basename-megaquery",
1788         );
1789     my $limitid = $limit->get_lock;
1790     while (not $limitid) {
1791         warn "Another process appears to be running a megaquery, sleeping";
1792         sleep 300;
1793         $limitid = $limit->get_lock;
1794     }
1795     my $dbi = mypgdbi();
1796     my $sqlimit = 30_000_000;
1797     my $elasticity = 2000;
1798     if ($Opt{maxfromdb} && $Opt{maxfromdb} < $sqlimit/$elasticity) {
1799         # the $elasticity here is a pure guess that says if we want
1800         # 200 hits, we should read 200*$elasticity records; indeed we
1801         # got 119 record from reading 200000
1802         $sqlimit = $elasticity*$Opt{maxfromdb};
1803     }
1804     # memory bummer:
1805     my $sql = "SELECT id,state,dist,version,fulldate
1806  FROM cpanstats
1807  WHERE type=2 and state='fail'
1808  ORDER BY id DESC LIMIT $sqlimit";
1809     print "Info: about to megaquery ".gmtime()." UTC\n";
1810     my $rows = my_get_query($dbi, $sql);
1811     print "Info: megaquery done ".gmtime()." UTC\n";
1812     return $rows;
1813 }
1814
1815 =item main_enqueuer
1816
1817
1818
1819 =cut
1820 sub main_enqueuer {
1821     my($want_ctgetreport, $touched_distv, $distroquestlabel, $anno, $timetogo,$urgenttimetogo) = @_;
1822  CTG: for my $ctxi (0..$#$want_ctgetreport) {
1823         my $ctx = $want_ctgetreport->[$ctxi];
1824         my($dist,$distv,$version) = @{$ctx}{"dist","distv","version"};
1825         $touched_distv->{$distv}=1;
1826         if ($Opt{pick}) {
1827             my $didit = call_ctgetreports($ctx,1+$ctxi,1+$#$want_ctgetreport);
1828             if ($didit) {
1829                 my $lfh = $didit->{lfh};
1830                 # update the yml, we might have to parse something in the new reports
1831                 my $dbi = mypgdbi();
1832                 $ctx = distroquestion($dbi,1+$ctxi,$distroquestlabel,$dist,$version,$lfh);
1833                 $ctx->{annotation} = $anno->{$distv};
1834                 $ctx->{lastcalc} = $didit->{lc_ts};
1835                 $ctx->{lc_pass} = $didit->{lc_pass};
1836                 $ctx->{lc_fail} = $didit->{lc_fail};
1837                 store_ctx($dbi,$ctx);
1838             }
1839         } else {
1840             enqueue($distv,$#$want_ctgetreport,$ctxi);
1841         }
1842         my $time = time;
1843         my $mustgo = 0;
1844         if ($time > $urgenttimetogo) {
1845             $mustgo = 1;
1846         } elsif ($ctxi == $#$want_ctgetreport){
1847             $mustgo = 1;
1848         } elsif (
1849             1
1850             && $time            >= $timetogo
1851             && $ctxi            >= MUST_CONSIDER
1852            ){
1853             $mustgo  = 1;
1854         }
1855         if ($mustgo) {
1856             my $utc = gmtime($timetogo);
1857             warn "DEBUG: proc[$$]ctxi[$ctxi]timetogo[$timetogo]that is[$utc UTC]";
1858             last CTG;
1859         }
1860     }
1861 }
1862
1863 =item this_urgent
1864
1865 Originally the decision whether a new calc was due was taken by a
1866 random function. We looked at the timestamp of the yaml file and of
1867 the slvfile. Then we read the yaml file and there we concluded on the
1868 upload date. Then we decided how often we want to calc a distro
1869 depending on its age. We mixed some randomness in and said this is
1870 urgent or not. Mostly crap.
1871
1872 Mixing in cpanstats_distrofacts and analysis:distv:calctimestamp?
1873 Especially interested in pass/fail on last calc and pass/fail now.
1874
1875 In cpanstats_distrofacts I see only (for Crypt-Password-0.28)
1876
1877    "db_fails" : 147,
1878    "db_maxid" : 41454838,
1879    "db_maxid_ts" : "2014-04-18T09:29:04.016700Z",
1880    "db_others" : 1,
1881    "db_passes" : 1923,
1882    "thirdfail" : "2012-02-19 02:40z",
1883    "thirdfailid" : "20108048",
1884    "thirdpass" : "2012-02-18 03:29z",
1885    "thirdpassid" : "20078591"
1886
1887 analysis:distv:calctimestamp has only 2500 entries at the moment, so
1888 is not too interesting yet.
1889
1890 Nein, distlookup ist unser Kandidat. Diese pg Tabelle hat
1891
1892  cuti_ts               | timestamp with time zone |
1893  cuti_pass             | integer                  |
1894  cuti_fail             | integer                  |
1895  last_calc_ts          | timestamp with time zone |
1896  lc_pass               | integer                  |
1897  lc_fail               | integer                  |
1898
1899 wobei cuti fuer counted_up_to_id steht. Und wobei last_calc_ts
1900 anscheinend redundant auf analysis:distv:calctimestamp ist.
1901
1902 =cut
1903 sub this_urgent {
1904     my($dbi,$dist,$version,$distv,$anno) = @_;
1905     $distv ||= "$dist-$version";
1906     $anno ||= read_annotations();
1907
1908     $dbi ||= db_quickaccess_handle();
1909     my $sql = "SELECT last_calc_ts, lc_pass, lc_fail, cuti_ts, cuti_pass, cuti_fail
1910                FROM distlookup WHERE distv=?";
1911     my $rows = my_get_query
1912         (
1913          $dbi,
1914          $sql,
1915          $distv
1916         );
1917     my $expensive_type = 0; # 9 huge, 0 not
1918     my $lowactivity = "";
1919     my $maybeexpensive = "";
1920     if (!$rows->[0][4] || !$rows->[0][5]) {
1921         return +{ this_urgent => 0 };
1922     }
1923     unless (grep { ($rows->[0][$_]||0)==0 } 1,2,4,5) {
1924         my($lc_ts,$lc_p,$lc_f,$cnt_ts,$cnt_p,$cnt_f) = @{$rows->[0]};
1925         if ($cnt_p>1.025*$lc_p || $cnt_f>1.025*$lc_f) { # arbitrary
1926             my $lc_total = $lc_p + $lc_f;
1927             if ( $lc_total < 2400 ){
1928                 return +{ this_urgent => 1 }; # activity
1929             } else {
1930                 my($limiting) = min($cnt_p,$cnt_f);
1931                 $maybeexpensive = "over 2400: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1932                 if ( $lc_total/$limiting > 250 ) { # arbitrary
1933                     $expensive_type = 9;
1934                 } else {
1935                     $expensive_type = 5;
1936                 }
1937             }
1938         } elsif ($cnt_p < $lc_p || $cnt_f < $lc_f) { # arbitrary
1939             # we would like to get rid of such brethren; maybe run verify-distlookup-lcpassfail.pl
1940             warn "Sigh, $distv has cnt_p < lc_p || cnt_f < lc_f ($cnt_p < $lc_p || $cnt_f < $lc_f)";
1941             return +{ this_urgent => 0 }; # fix up bad numbers
1942         } elsif ($cnt_p == $lc_p && $cnt_f == $lc_f) {
1943             $lowactivity = "NO growth: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1944         } elsif ($cnt_p < 1.002*$lc_p && $cnt_f < 1.002*$lc_f) { # arbitrary
1945             $lowactivity = "small growth: $lc_p=>$cnt_p, $lc_f=>$cnt_f";
1946         }
1947     }
1948
1949     my($csdfacts) = cpanstats_distrofacts($dbi,$dist,$version,$distv,undef);
1950     if (
1951         $csdfacts
1952         && ! $expensive_type
1953         && $csdfacts->{allversions}
1954         && "ARRAY" eq ref $csdfacts->{allversions}
1955         && scalar @{$csdfacts->{allversions}}
1956         && exists $csdfacts->{allversions}[-1]{version}
1957         && $csdfacts->{allversions}[-1]{version} ne $version
1958        ) {
1959         warn "DEBUG: this is urgent: $distv $version ne $csdfacts->{allversions}[-1]{version}";
1960         return +{ this_urgent => 1 };
1961     }
1962     if ($lowactivity) {
1963         return +{ this_urgent => 0, why_not_urgent => $lowactivity };
1964     }
1965
1966     my $averagewait = 86400; # XXX arbitrary: the smaller the more
1967                              # calc; Actually: we use rand to avoid
1968                              # spikes; zero waits and a double of this
1969                              # wait are equally likely
1970
1971     my $minimumwait = 1.9; # XXX arbitrary: the smaller the more calc;
1972                            # Actually: for every year of age of the
1973                            # distro we add this times $averagewait
1974                            # waiting time. Since no age below 1 is
1975                            # possible, this is the minimum wait;
1976                            # setting from 1.7.to 1.8 when the usually
1977                            # set task was 3500 but we only calculated
1978                            # 1000; either we increase the mincalc or
1979                            # reduce the pensum, I would guess;
1980                            # 20160527: taking back to (1.7, 2500),
1981                            # disk gets too full too quickly
1982
1983     if ($maybeexpensive) {
1984         # XXX arbitrary: if we have indications that the calc takes a
1985         # longer time, push back
1986         $minimumwait = $expensive_type >= 6 ? 42 : 15;
1987     }
1988     if ($anno->{$distv} && $minimumwait < 5) {
1989         $minimumwait = 5; # e.g. GFUJI/MouseX-Getopt-0.34.tar.gz
1990     }
1991
1992     my $slv_file = slv_file($distv);
1993     my @slvstat = stat ($slv_file . "dv.gz");
1994     @slvstat = stat $slv_file unless @slvstat;
1995     my $age_of_calc = @slvstat ? time-$slvstat[9] : 999999;
1996
1997     my $yaml = read_ctx($distv);
1998     if ($anno->{$distv}
1999         and (!$yaml->{annotation} || $yaml->{annotation} ne $anno->{$distv})) {
2000         # looks like this annotation has not been stored yet
2001         return +{ this_urgent => 1 };
2002     }
2003     my ($this_urgent, $why_not_urgent) = (0,"");
2004     my $age_in_secs = eval { age_in_secs($yaml->{upload_date}) }; # distro age in secs
2005     if ($@ || !$age_in_secs) {
2006         my $err = $@;
2007         require Carp;
2008         Carp::cluck("WARNING: skipping '$yaml->{distv}' error[$@] upload_date[$yaml->{upload_date}] distv[$distv]");
2009         $this_urgent = 0;
2010         if ($err) {
2011             $why_not_urgent = $err;
2012         } else {
2013             $why_not_urgent = "no upload date";
2014         }
2015         return +{ this_urgent => $this_urgent, why_not_urgent => $why_not_urgent};
2016     }
2017     my $seconds_per_year = 86400*365.25;
2018     my $age_points = $age_in_secs < $seconds_per_year ?
2019         1 : $age_in_secs/$seconds_per_year; # between 1 and 8
2020     my $rand = int(rand(2*$averagewait));
2021     my $rand2 = int($age_points*($rand+$averagewait*$minimumwait));
2022
2023     $this_urgent = $age_of_calc > $rand2; # XXX arbitrary
2024     warn sprintf "DEBUGurg: age_of_calc[%s] age_points[%.3f] rand[%s] rand2[%s] urg[%d]\n",
2025         $age_of_calc, $age_points, $rand, $rand2, $this_urgent;
2026     if (!$this_urgent) {
2027         if (!@slvstat) {
2028             $this_urgent = 1;
2029             warn "DEBUG urg2: urgent because no slvstat"; # never happens
2030         } else {
2031             $why_not_urgent = "age/point calculations";
2032         }
2033     }
2034     return +{ this_urgent => $this_urgent, why_not_urgent => $why_not_urgent};
2035 }
2036
2037 my($timetogo,$urgenttimetogo);
2038 {
2039     $timetogo       = $^T + ($Opt{mincalctime} || MIN_CALCTIME);
2040     $urgenttimetogo = MAX_CALCTIME + $^T;
2041 }
2042 MAIN: {
2043     my $mainentrytime = time;
2044     my $solved = [];
2045     my $anno = {};
2046     if ($Opt{onlystartwhennojobs}) {
2047         my $redis = myredis;
2048     WAITNOQ: while () {
2049             my($zcard) = $redis->zcard("analysis:jobqueue:q");
2050             last WAITNOQ if $zcard == 0;
2051             sleep 60;
2052         }
2053     }
2054     if ($Opt{pick}) {
2055         warn "saw --pick=$Opt{pick}, skipping readdir on solved/ directory";
2056         my $shadow_anno = read_annotations();
2057         if (exists $shadow_anno->{$Opt{pick}}) {
2058             $anno->{$Opt{pick}} = $shadow_anno->{$Opt{pick}};
2059         }
2060     } else {
2061         $anno = read_annotations();
2062         unless (defined $Opt{maxfromsolved} && 0 == $Opt{maxfromsolved}) {
2063             # looks in workdir/solved/ where we find eg. a2pdf-1.13.{slv,slvdv,yml}
2064             $solved = CPAN::Blame::Model::Solved->all("readdir");
2065         }
2066     }
2067     my(%seen,@want_ctgetreport);
2068     # revisit all our friends first
2069     my $touched_distv = {};
2070  ANNO_SOLVED: for my $set
2071         (
2072          {name => "anno", data => $anno}, # anno is a hashref
2073          {name => "solved", data => $solved}, # solved is an arrayref
2074         ) {
2075         my @k; # names like "a2pdf-1.13"
2076         my $urgent = $Opt{urgent} || 0;
2077         if (0) {
2078         } elsif ($Opt{pick}) {
2079             # pick trumps, the others don't play when we are a worker
2080             @k = $Opt{pick};
2081         } elsif ($set->{name} eq "anno") {
2082             @k = keys %{$set->{data}};
2083             if (defined $Opt{maxfromannotate}) {
2084                 pop @k while @k > $Opt{maxfromannotate};
2085             }
2086         } elsif ($set->{name} eq "solved") {
2087             @k = map { $_->{distv} } @{$set->{data}};
2088             if (defined $Opt{maxfromsolved}) {
2089                 pop @k while @k > $Opt{maxfromsolved};
2090             }
2091         } else {
2092             die;
2093         }
2094         my $distroquestlabel = substr($set->{name},0,4) . "-" . scalar @k; # gives a bit of orientation in the runlog
2095         my $i = 0;
2096     DISTV: for my $k (@k) {
2097             $touched_distv->{$k}=1;
2098             my $d = CPAN::DistnameInfo->new("FOO/$k.tgz");
2099             my $dist = $d->dist;
2100             my $version = $d->version;
2101             ++$i;
2102             next DISTV if $seen{$dist,$version}++;
2103             my($this_urgent, $why_not_urgent);
2104             my $slv_file = slv_file($k);
2105             if ($urgent) {
2106                 $this_urgent = 1;
2107             } elsif (! -e ($slv_file."dv.gz") && ! -e ($slv_file."dv")) {
2108                 $this_urgent = 1;
2109             } elsif ($Opt{pick}) {
2110                 $this_urgent = 1;
2111             } else {
2112                 my $href = this_urgent(undef,$dist,$version,$k,$anno);
2113                 ($this_urgent, $why_not_urgent) = @{$href}{qw(this_urgent why_not_urgent)};
2114             }
2115             unless ($this_urgent){
2116                 printf "Warning: skipping %s (%s)\n", $k, $why_not_urgent;
2117                 next DISTV;
2118             }
2119             my $pgdbi = mypgdbi();
2120             my $ctx = distroquestion($pgdbi,$i,$distroquestlabel,$dist,$version,undef) or next;
2121             $ctx->{annotation} = $anno->{$k};
2122             store_ctx($pgdbi,$ctx);
2123             push @want_ctgetreport, $ctx;
2124         }
2125     } # ANNO_SOLVED
2126     my $rows = [];
2127     if ($Opt{pick}) {
2128     } else {
2129         unless (defined $Opt{maxfromdb} && 0==$Opt{maxfromdb}) {
2130             $rows = megaquery();
2131         }
2132     }
2133     my $skip_random = 0;
2134     my $i = 0;
2135     my $mindate;
2136     {
2137         my @now = gmtime;
2138         $now[4]++;
2139         $now[5]+=1900;
2140         $mindate = sprintf "%04d%02d%02d%02d%02d", $now[5]-$CPAN::Blame::Config::Cnntp::Config->{maxyears}, @now[reverse 1..4];
2141     }
2142     warn sprintf
2143         (
2144          "DEBUG: before going through megaquery result: array want_ctgetreport[%d] rows from megaquery[%d]\n",
2145          scalar @want_ctgetreport,
2146          scalar @$rows,
2147         );
2148     my $distroquestlabel = "B" . scalar @$rows;
2149     my $why_last_article = "";
2150  ARTICLE: while (my $row = shift @$rows) {
2151         sleep 0.3;
2152         my($id,$state,$dist,$version,$date) = @$row;
2153         unless ($id){
2154             $why_last_article = "no id in row[@$row]";
2155             last ARTICLE;
2156         }
2157         if ($date lt $mindate){
2158             $why_last_article = "date[$date] lt mindate[$mindate] i[$i]";
2159             last ARTICLE;
2160         }
2161         next ARTICLE unless defined $dist and defined $version;
2162         if ($seen{$dist,$version}++){
2163             $why_last_article = "last action was skipping $dist,$version (reaching last ARTICLE via next)";
2164             next ARTICLE;
2165         }
2166         # note: when we arrive here. We will display current $i in the leftmost column as in
2167         # 170 B2801844 13-10-29 147: 21:  0 KSTAR/Dancer-Plugin-DynamicConfig-0.04 (<0.07)
2168         $i++;
2169         if ($Opt{maxfromdb} && $i > $Opt{maxfromdb}) {
2170             last ARTICLE;
2171         }
2172         my $pgdbi = mypgdbi();
2173         my $ctx = distroquestion($pgdbi,$i,$distroquestlabel,$dist,$version,undef) or next;
2174         $ctx->{annotation} = $anno->{$ctx->{distv}};
2175         store_ctx($pgdbi,$ctx);
2176         if ($ctx->{greenish} && $ctx->{greenish} >= 3) {
2177             push @want_ctgetreport, $ctx;
2178         }
2179         if ($i >= 487) { # XXX arbitrary
2180             if ($skip_random) {
2181                 # note: in 2013 we never reached 800, we reached the 8
2182                 # year old distros before that, yesterday at $i==666,
2183                 # and want_ctgetreport had 3823 entries
2184                 if ($i >= 1200 && @want_ctgetreport >= 200) { # XXX arbitrary
2185                     $why_last_article = "i[$i] > xxx and want_ctgetreport > 150";
2186                     last ARTICLE;
2187                 } elsif ($i >= 800 && @want_ctgetreport >= 300) { # XXX arbitrary
2188                     $why_last_article = "i[$i] > xxx and want_ctgetreport > 200";
2189                     last ARTICLE;
2190                 }
2191             } else {
2192                 printf "Debug: switching to skip_random mode\n";
2193                 $skip_random = 1;
2194             }
2195         }
2196         if ($skip_random) {
2197             # compensate for the fact that we do not have and do not
2198             # even want to provide the computing power to calculate
2199             # all possible regressions simultaneously; yes, we are a
2200             # bit sloppy but do not believe anybody will notice; some
2201             # day we may want to stop this program to go into the
2202             # oldest data in the database because it will become
2203             # worthless; then we probably want to make sure all data
2204             # in a certain range get processed exactly once.
2205             my $skip = int rand 40000; # XXX arbitrary
2206             splice @$rows, 0, $skip;
2207         }
2208         sleep 0.1;
2209         $why_last_article = "simply reached end of loop";
2210     }
2211     warn sprintf "DEBUG: Reached last ARTICLE why?[%s] array want_ctgetreport[%d]", $why_last_article, scalar @want_ctgetreport;
2212     @want_ctgetreport = sort
2213         {
2214             # Wishlist: first sort criterium should be in favor of
2215             # those who have no calc yet at all. But then we might
2216             # schedule them too early because cpantesters are behind
2217             # log.txt
2218             ($b->{upload_date}||"") cmp ($a->{upload_date}||"")
2219             ||
2220             ($a->{distro_age}||0) <=> ($b->{distro_age}||0)
2221             ||
2222             $a <=> $b # crap, just the address because there is nothing better in sight
2223         } @want_ctgetreport;
2224     $distroquestlabel = "ctg-" . scalar @want_ctgetreport;
2225     main_enqueuer(\@want_ctgetreport, $touched_distv, $distroquestlabel, $anno, $timetogo,$urgenttimetogo);
2226     if ($Opt{pick}) {
2227         warn "nothing will be deleted, we're on a picking trip";
2228     } else {
2229         # XXX temporarily disabling cleanup_quick on 2014-01-01;
2230         # because we do not understand the exact implications of the
2231         # queuing system; but this for sure must be re-examined.
2232         #### cleanup_quick($touched_distv);
2233     WAITTOGO: while (time < $timetogo) {
2234             if ($Opt{leavewhennojobsleft}) {
2235                 my $redis = myredis;
2236                 my($zcard) = $redis->zcard("analysis:jobqueue:q");
2237                 last WAITTOGO if $zcard == 0;
2238             }
2239             sleep 60;
2240         }
2241     }
2242 }
2243
2244
2245 1;
2246
2247 __END__
2248
2249 =back
2250
2251 =head1 BUGS
2252
2253 TRIAL?
2254
2255 Too slow update cycle
2256
2257 Often does not recognize when a newer version is available, maybe only
2258 when the newer version is all-green or so?
2259
2260 Sqlite
2261
2262 =head1 HISTORICAL NOTES
2263
2264 show the most recent FAILs on cpantesters. Compare to annotations.txt
2265 which I maintain manually in annotations.txt. Roughly the job is
2266 organized as (1) update the database syncing with cpantesters, (2)
2267 process (2.1) annotations, (2.2) previously solved regressions, (2.3)
2268 database to schedule some 1000 batchjob-candidates with (2.3.1) is the
2269 megaquery and (2.3.2) steps through it. (3) Run these batchjobs, many
2270 of which are being skipped. (4) delete several thousand outdated files
2271 and/or directories. Timings on 2013-10-29 and -30
2272
2273   |         | 20131029 | 20131127 |
2274   |---------+----------+----------|
2275   | (1)     | 06:30:09 |          |
2276   | (2.1)   | 10:54:22 | 10:28:49 |
2277   | (2.2)   | 15:15:43 | 11:09:37 |
2278   | (2.3.1) | 20:41:42 | 13:26:49 |
2279   | (2.3.2) | 21:08:51 | 13:29:02 |
2280   | (3)     | 22:53:15 | 14:29:28 |
2281   | (4)     | 16:44:07 |          |
2282   | (T)     | 16:45:00 |          |
2283
2284 The schema of cpanstats.db once was considered to be
2285
2286   0 | id       | 5379605                         |5430514
2287   1 | state    | pass                            |fail
2288   2 | postdate | 200909                          |
2289   3 | tester   | bingos@cpan.org                 |
2290   4 | dist     | Yahoo-Photos                    |Apache-Admin-Config
2291   5 | version  | 0.0.2                           |0.94
2292   6 | platform | i386-freebsd-thread-multi-64int |i386-freebsd
2293   7 | perl     | 5.10.0                          |
2294   8 | osname   | freebsd                         |
2295   9 | osvers   | 7.2-release                     |7.2-release
2296  10 | date     | 200909190440                    |200909190440
2297
2298 but has changed to
2299
2300    id            INTEGER PRIMARY KEY, -- 1
2301    state         TEXT,                -- 2
2302    postdate      TEXT,                -- 3
2303    tester        TEXT,                -- 4
2304    dist          TEXT,                -- 5
2305    version       TEXT,                -- 6
2306    platform      TEXT,                -- 7
2307    perl          TEXT,                -- 8
2308    osname        TEXT,                -- 9
2309    osvers        TEXT,                -- 10
2310    date          TEXT,                -- 11
2311    guid          char(36) DEFAULT '', -- 12
2312    type          int(2) default 0)    -- 13
2313
2314 guid and type are new. guid replaces id but is in a different format. schema is generated by
2315
2316   Revision history for Perl module CPAN::Testers::Data::Generator.
2317
2318   0.41    18/03/2010
2319           - fixes to change the 'id' (was NNTP ID) to an auto incremental field.
2320           - reworked logic to better fit latest changes.
2321           - added repository to META.yml.
2322           - documentation updates.
2323
2324   0.40    02/02/2010
2325           - fixes to accommodate GUID changes.
2326           - added support for 'type' field.
2327
2328 From reading the source, type seems to be 0 or 2 for valid records. 1
2329 is for pause announcements and 3 is for disabled reports. IIUC 0 is
2330 for old records and 2 for new ones. That would mean that there is a
2331 constant number of records with type==0?
2332
2333 A few months ago we counted:
2334
2335   sqlite> select type,count(*) from cpanstats group by type;
2336   0|1570
2337   1|123723
2338   2|6899753
2339   3|15131
2340
2341 and today:
2342
2343   sqlite> select type,count(*) from cpanstats group by type;
2344   0|1570
2345   1|130858
2346   2|7745256
2347   3|15131
2348
2349 So we can rely on having to read only type==2 from now on.
2350
2351 But before we can do anything we must
2352 s/CPAN::WWW::Testers::Generator::Database/CPAN::Testers::Data::Generator/g; or
2353 something equivalent.
2354
2355 I see no reason why I should make use of the guid except maybe for
2356 links to cpantesters. Internal stuff should work with id just like it
2357 always did.
2358
2359 Update 2011-10-12 andk: schema change again, new schema is:
2360
2361    id          INTEGER PRIMARY KEY,    -- 1
2362    guid        TEXT,                   -- 12
2363    state       TEXT,                   -- 2
2364    postdate    TEXT,                   -- 3
2365    tester      TEXT,                   -- 4
2366    dist        TEXT,                   -- 5
2367    version     TEXT,                   -- 6
2368    platform    TEXT,                   -- 7
2369    perl        TEXT,                   -- 8
2370    osname      TEXT,                   -- 9
2371    osvers      TEXT,                   -- 10
2372    fulldate    TEXT,                   -- is new, probably was date (11)
2373    type        INTEGER                 -- 13
2374
2375
2376
2377 =head1 TODO
2378
2379 open tickets?
2380