Collecting Results When Some Jobs Never Return

#!/usr/bin/perl
# stage.pl -- build the run area that Chapters 25.4 to 25.6 leave behind for
# regression r2, with every log produced by the real simulator. Each run ends
# in one of the ways those chapters measured.
use strict;
use warnings;
use File::Path qw(make_path remove_tree);
use Time::HiRes qw(sleep);

my $REGR = "r2";

# id, test, seed, extra args, how it ended
my @plan = (
    [qw(smoke_s1  smoke  1), "",          "finished"],
    [qw(corner_s1 corner 1), "",          "finished"],
    [qw(rand_s2   rand   2), "",          "finished"],
    [qw(rand_s3   rand   3), "",          "finished"],
    [qw(bogus_s1  bogus  1), "",          "finished"],
    [qw(stall_s1  stall  1), "",          "timeout"],        # the waiter killed it (TERM)
    [qw(stall_s2  stall  2), "",          "farm_kill"],      # the farm killed it (KILL)
    [qw(rand_s5   rand   5), "+n=400000", "farm_term"],      # the farm stopped it (TERM)
    [qw(smoke_s9  smoke  9), "",          "never_started"],
    [qw(rand_s4   rand   4), "",          "not_submitted"],
);

sub sim {                                  # run the bench into a log; maybe stop it
    my ($log, $sig, @args) = @_;
    my $pid = fork // die "fork: $!\n";
    if ($pid == 0) {
        open STDOUT, ">", $log or exit 126;
        open STDERR, ">&", \*STDOUT or exit 126;
        exec "bin/simv", @args;
        exit 127;
    }
    if ($sig) { sleep 0.8; kill $sig, $pid }
    waitpid($pid, 0);
    return $? >> 8;
}
sub put {
    my ($path, $text) = @_;
    open my $f, ">", $path or die "$path: $!\n";
    print {$f} $text;
    close $f;
}

system("bin/build") == 0 or die "build failed\n";
system("bin/simv +test=smoke > /dev/null");   # warm-up: the first launch is the slowest
remove_tree("runs");
make_path("runs");

# Yesterday (regression r1) used the same fixed seeds, so two of its run
# directories have today's names -- and one directory today's plan no longer has.
for my $old (["smoke_s9", 9], ["old_s7", 7]) {
    my ($id, $seed) = @$old;
    make_path("runs/$id");
    my $exit = sim("runs/$id/sim.log", undef, "+test=smoke", "+seed=$seed");
    put("runs/$id/status", "exit=$exit\nregr=r1\n");
    put("runs/$id/done", "");
}

my ($plan, $jobs, $wait) = ("", "", "");
my $job = 4100;
for my $p (@plan) {
    my ($id, $test, $seed, $extra, $how) = @$p;
    my @args = ("+test=$test", "+seed=$seed", $extra ? $extra : ());
    my $dir  = "runs/$id";
    make_path($dir);
    put("$dir/cmd.sh", "#!/bin/sh\ncd \"\$(dirname \"\$0\")/../..\" || exit 2\nexec bin/simv @args\n");
    $plan .= "$id\t$test\t$seed\n";
    next if $how eq "not_submitted";              # refused: no job, no log
    $jobs .= ++$job . "\t$id\n";
    if ($how eq "never_started") { $wait .= "$id\tREGRESSION DEADLINE: never started\n"; next }
    if ($how eq "finished") {
        my $exit = sim("$dir/sim.log", undef, @args);
        put("$dir/status", "exit=$exit\nregr=$REGR\n");
        put("$dir/done", "");
        $wait .= "$id\tfinished (done file)\n";
    } elsif ($how eq "timeout") {
        sim("$dir/sim.log", "TERM", @args);       # job.sh died too: no status, no done
        $wait .= "$id\tTIMEOUT: ran over 2s\n";
    } elsif ($how eq "farm_kill") {
        sim("$dir/sim.log", "KILL", @args);
        $wait .= "$id\tended without done file\n";
    } elsif ($how eq "farm_term") {
        sim("$dir/sim.log", "TERM", @args);
        $wait .= "$id\tended without done file\n";
    }
}
put("runs/plan.tsv", "run_id\ttest\tseed\n$plan");
put("runs/jobs.tsv", "job_id\trun_id\n$jobs");
put("runs/wait.tsv", "run_id\twhy\n$wait");
put("runs/REGRESSION", "$REGR\n");
print "staged regression $REGR: ", scalar(@plan), " planned runs\n";

#!/usr/bin/perl
# buffer_demo.pl -- the same simulation stopped after 0.8 s by TERM and by
# KILL, stopped by TERM during its start-up, and a hung test stopped by KILL:
# what reaches the log?
use strict;
use warnings;
use Time::HiRes qw(sleep);

system("bin/build") == 0 or die "build failed\n";
system("bin/simv +test=smoke > /dev/null");   # warm-up: the first launch is the slowest
sub stopped_log {
    my ($sig, $after, @args) = @_;
    my $pid = fork // die "fork: $!\n";
    if ($pid == 0) {
        open STDOUT, ">", "stopped.log" or exit 126;
        open STDERR, ">&", \*STDOUT or exit 126;
        exec "bin/simv", @args;
        exit 127;
    }
    sleep $after;
    kill $sig, $pid;
    waitpid($pid, 0);
    my $signal = $? & 127;
    open my $fh, "<", "stopped.log" or die;
    my @l = <$fh>;
    return { signal  => $signal,
             bytes   => -s "stopped.log",
             errors  => scalar(grep { /^ERROR:/ } @l),
             header  => scalar(grep { /^TEST \S+ SEED/ } @l),
             verdict => scalar(grep { /^TEST (?:PASSED|FAILED)/ } @l) };
}

my $t = stopped_log("TERM", 0.8,   "+test=rand", "+seed=5", "+n=400000");
my $k = stopped_log("KILL", 0.8,   "+test=rand", "+seed=5", "+n=400000");
my $e = stopped_log("TERM", 0.002, "+test=rand", "+seed=5", "+n=400000");
my $s = stopped_log("KILL", 0.8,   "+test=stall");
printf "TERM: header line %s, ERROR lines: %s, verdict line: %s\n",
       $t->{header} ? "present" : "MISSING", $t->{errors} > 100 ? "more than 100" : $t->{errors},
       $t->{verdict} ? "yes" : "no";
printf "KILL: size is a whole number of 4096-byte blocks: %s; verdict line: %s\n",
       $k->{bytes} % 4096 == 0 ? "yes" : "no", $k->{verdict} ? "yes" : "no";
printf "TERM during start-up: ended by signal %d, %d bytes in the log\n", $e->{signal}, $e->{bytes};
printf "KILL on the hung test: %d bytes; its header line, printed at time 0: %s\n",
       $s->{bytes}, $s->{header} ? "present" : "MISSING";

TERM: header line present, ERROR lines: more than 100, verdict line: no
KILL: size is a whole number of 4096-byte blocks: yes; verdict line: no
TERM during start-up: ended by signal 15, 0 bytes in the log
KILL on the hung test: 0 bytes; its header line, printed at time 0: MISSING

# classify.pl -- the log-only classifier both quick collectors share:
# a verdict line wins, otherwise errors mean FAIL, otherwise UNKNOWN.
use strict;
use warnings;

sub classify {
    my ($log) = @_;
    open my $fh, "<", $log or return "NO_LOG";
    my $text = do { local $/; <$fh> } // "";
    return "PASS"    if $text =~ /^TEST PASSED$/m;
    return "FAIL"    if $text =~ /^(?:TEST FAILED|ERROR:)/m;
    return "UNKNOWN";
}
1;

#!/usr/bin/perl
# glob_collect.pl -- collect by looking at whatever logs are in the run area.
use strict;
use warnings;
require "./classify.pl";

my %n;
for my $log (sort glob "runs/*/sim.log") {
    my ($id) = $log =~ m{^runs/([^/]+)/};
    my $v = classify($log);
    printf "  %-10s %s\n", $id, $v;
    $n{$v}++;
}
my $rows = 0; $rows += $_ for values %n;
printf "  %d rows; pass rate %d%%\n", $rows, 100 * ($n{PASS} // 0) / $rows;

#!/usr/bin/perl
# plan_collect.pl -- the registry's loop: every PLANNED run, log or NO_LOG.
use strict;
use warnings;
require "./classify.pl";

open my $p, "<", "runs/plan.tsv" or die; <$p>;
my %n;
while (<$p>) {
    my ($id) = split /\t/;
    my $log = "runs/$id/sim.log";
    my $v = -e $log ? classify($log) : "NO_LOG";
    printf "  %-10s %s\n", $id, $v;
    $n{$v}++;
}
my $rows = 0; $rows += $_ for values %n;
printf "  %d rows; pass rate %d%%\n", $rows, 100 * ($n{PASS} // 0) / $rows;

#!/usr/bin/perl
# collect_demo.pl -- stage one regression's run area, then collect it three ways.
use strict;
use warnings;

$| = 1;
system("$^X stage.pl") == 0 or die "stage.pl failed\n";
print "\n--- 1. every log found in the run area ---\n";
system($^X, "glob_collect.pl");
print "\n--- 2. every planned run, log or NO_LOG ---\n";
system($^X, "plan_collect.pl");
print "\n--- 3. every planned run, all of the evidence ---\n";
system($^X, "collect.pl");
print "(collect.pl exit ", $? >> 8, ")\n";

staged regression r2: 10 planned runs

--- 1. every log found in the run area ---
  bogus_s1   UNKNOWN
  corner_s1  FAIL
  old_s7     PASS
  rand_s2    FAIL
  rand_s3    PASS
  rand_s5    FAIL
  smoke_s1   PASS
  smoke_s9   PASS
  stall_s1   UNKNOWN
  stall_s2   UNKNOWN
  10 rows; pass rate 40%

--- 2. every planned run, log or NO_LOG ---
  smoke_s1   PASS
  corner_s1  FAIL
  rand_s2    FAIL
  rand_s3    PASS
  bogus_s1   UNKNOWN
  stall_s1   UNKNOWN
  stall_s2   UNKNOWN
  rand_s5    FAIL
  smoke_s9   PASS
  rand_s4    NO_LOG
  10 rows; pass rate 30%

--- 3. every planned run, all of the evidence ---
RUN        VERDICT       REASON
smoke_s1   PASS          TEST PASSED, 0 errors, exit 0
corner_s1  FAIL          1 ERROR line(s)
rand_s2    FAIL          1 ERROR line(s)
rand_s3    PASS          TEST PASSED, 0 errors, exit 0
bogus_s1   FATAL         the bench stopped itself (exit 1)
stall_s1   TIMEOUT       stopped by the waiter (TIMEOUT: ran over 2s)
stall_s2   EMPTY_LOG     zero bytes; waiter: ended without done file
rand_s5    KILLED        ended before its job script did; the log already shows ERROR lines
smoke_s9   NOT_STARTED   the regression deadline came first (its directory holds files from regression r1: ignored)
rand_s4    NOT_SUBMITTED the farm never accepted it

PASS 2   FAIL 3   NO VERDICT 5   (10 planned, 10 reported)
rules no run reached this time: NO_LOG WRONG_RUN NO_VERDICT
regression INCOMPLETE: 3 failed, 5 without a verdict
(collect.pl exit 1)

my %e = (
    job    => ...,   # did the farm accept it?         (jobs.tsv)
    wait   => ...,   # why did the waiter stop?         (wait.tsv)
    exit   => ...,   # the simulator's exit status      (status)
    done   => ...,   # did the job script finish?       (done)
    log    => ...,   # is there a log, and its size
    header => ...,   # what the log says was run
    passed => ..., failed => ..., fatal => ..., errors => ...,
    asked  => ...,   # what the plan says should have run
);

#!/usr/bin/perl
# collect.pl -- one verdict, with a reason, for EVERY planned run, from all the
# evidence the runner kept; write runs/results.tsv; exit with a status that
# says whether the regression is complete.
#   exit 0  every run passed
#   exit 1  at least one run failed
#   exit 3  no run failed, but some runs have no verdict
use strict;
use warnings;
use List::Util qw(first);

my $REGR = do { open my $f, "<", "runs/REGRESSION" or die "runs/REGRESSION: $!\n"; <$f> };
chomp $REGR;

sub read_tsv {                             # first column => rest of the row
    my ($file) = @_;
    open my $fh, "<", $file or die "$file: $!\n";
    <$fh>;                                 # header
    return map { chomp; my ($k, @rest) = split /\t/; ($k => \@rest) } <$fh>;
}
my @plan = do {                            # plan order is report order
    open my $p, "<", "runs/plan.tsv" or die "runs/plan.tsv: $!\n";
    <$p>;
    map { chomp; my ($id, $test, $seed) = split /\t/; { id => $id, test => $test, seed => $seed } } <$p>;
};
my %jobs   = read_tsv("runs/jobs.tsv");    # job id => [run id]
my %job_of = map { $_->[0] => 1 } values %jobs;
my %wait   = read_tsv("runs/wait.tsv");    # run id => [why waiting ended]
my %why    = map { $_ => $wait{$_}[0] } keys %wait;

sub evidence {                             # everything we know about one run
    my ($r) = @_;
    my $dir = "runs/$r->{id}";
    my %e = (job => $job_of{ $r->{id} }, wait => $why{ $r->{id} } // "", note => "",
             asked => "TEST $r->{test} SEED $r->{seed}");
    my %st = -e "$dir/status" ? do { open my $s, "<", "$dir/status"; map { /^(\w+)=(.*)$/ } <$s> } : ();
    if (defined $st{regr} && $st{regr} ne $REGR) {         # yesterday's files
        $e{note} = " (its directory holds files from regression $st{regr}: ignored)";
        return \%e;                                        # trust none of them
    }
    $e{exit} = $st{exit};
    $e{done} = -e "$dir/done";
    if (open my $fh, "<", "$dir/sim.log") {
        $e{log}  = 1;
        $e{size} = -s "$dir/sim.log";
        while (my $l = <$fh>) {
            $e{header} //= $1 if $l =~ /^(TEST \S+ SEED \S+)$/;
            $e{passed}  = 1   if $l =~ /^TEST PASSED$/;
            $e{failed}  = 1   if $l =~ /^TEST FAILED/;
            $e{fatal}   = 1   if $l =~ /^FATAL:/;
            $e{errors}++      if $l =~ /^ERROR:/;
        }
    }
    return \%e;
}

# The verdict ladder: the first rule whose test is true decides.
my @RULES = (
  [ NOT_SUBMITTED => sub { !$_[0]{job} },                  sub { "the farm never accepted it" } ],
  [ NOT_STARTED   => sub { $_[0]{wait} =~ /never started/ }, sub { "the regression deadline came first" } ],
  [ NO_LOG        => sub { !$_[0]{log} },                  sub { "no log was written" } ],
  [ EMPTY_LOG     => sub { !$_[0]{size} },                 sub { "zero bytes; waiter: $_[0]{wait}" } ],
  [ TIMEOUT       => sub { $_[0]{wait} =~ /^TIMEOUT|was running/ }, sub { "stopped by the waiter ($_[0]{wait})" } ],
  [ KILLED        => sub { !$_[0]{done} },                 sub { "ended before its job script did"
                                                                 . ($_[0]{errors} ? "; the log already shows ERROR lines" : "") } ],
  [ FATAL         => sub { $_[0]{fatal} },                 sub { "the bench stopped itself (exit $_[0]{exit})" } ],
  [ WRONG_RUN     => sub { ($_[0]{header} // "") ne $_[0]{asked} }, sub { "log says '" . ($_[0]{header} // "") . "'" } ],
  [ FAIL          => sub { $_[0]{failed} || $_[0]{errors} }, sub { ($_[0]{errors} // 0) . " ERROR line(s)" } ],
  [ NO_VERDICT    => sub { !$_[0]{passed} },               sub { "finished without a TEST PASSED line" } ],
  [ PASS          => sub { 1 },                            sub { "TEST PASSED, 0 errors, exit $_[0]{exit}" } ],
);
my %CATEGORY = (PASS => "PASS", FAIL => "FAIL", FATAL => "FAIL");   # all else: NO VERDICT

my (%n, %fired);
open my $out, ">", "runs/results.tsv" or die "runs/results.tsv: $!\n";
print {$out} "run_id\ttest\tseed\tverdict\tcategory\treason\n";
printf "%-10s %-13s %s\n", "RUN", "VERDICT", "REASON";
for my $r (@plan) {
    my $e = evidence($r);
    my $rule = first { $_->[1]->($e) } @RULES;    # stops at the first true rule
    my ($verdict, $reason) = ($rule->[0], $rule->[2]->($e) . $e->{note});
    my $cat = $CATEGORY{$verdict} // "NO VERDICT";
    $reason =~ s/[\t\n]/ /g;               # keep the TSV one line per run
    print {$out} join("\t", @$r{qw(id test seed)}, $verdict, $cat, $reason), "\n";
    printf "%-10s %-13s %s\n", $r->{id}, $verdict, $reason;
    $n{$cat}++;
    $fired{$verdict}++;
}
close $out or die "runs/results.tsv: $!\n";

my $reported = 0; $reported += $_ for values %n;
die "BUG: ", scalar @plan, " planned but $reported reported\n" unless $reported == @plan;
printf "\nPASS %d   FAIL %d   NO VERDICT %d   (%d planned, %d reported)\n",
       map({ $n{$_} // 0 } "PASS", "FAIL", "NO VERDICT"), scalar @plan, $reported;
my @unused = map { $_->[0] } grep { !$fired{ $_->[0] } } @RULES;
print "rules no run reached this time: @unused\n" if @unused;

my $status = $n{FAIL} ? 1 : $n{"NO VERDICT"} ? 3 : 0;
print $status == 0 ? "regression COMPLETE: all passed\n"
    : "regression ", ($n{"NO VERDICT"} ? "INCOMPLETE" : "COMPLETE"),
      ": ", ($n{FAIL} // 0), " failed, ", ($n{"NO VERDICT"} // 0), " without a verdict\n";
exit $status;