Project: Regression Dashboard Generator

// tb_nightly.v -- six tests, UVM-SHAPED report lines (not UVM: UVM cannot
// run on this toolchain), and two "nights" of the design:
//   +TEST=name +SEED=n +NIGHT=1|2
// night 2 is the next day's build: the PROTO bug in alu_burst is fixed,
// and a new CSR bug appears. Message texts contain a comma, double quotes,
// '<' and '&' on purpose -- real messages do, and the reports must cope.
`timescale 1ns/1ps

module tb_nightly;
  integer seed, night, n_err;
  reg [8*16-1:0] test;

  task error(input [8*8-1:0] id, input [8*72-1:0] msg);
    begin
      $display("UVM_ERROR tb/tb_nightly.v(0) @ %0t: uvm_test_top.env [%0s] %0s", $time, id, msg);
      n_err = n_err + 1;
    end
  endtask

  initial begin
    n_err = 0;
    if (!$value$plusargs("TEST=%s", test))   test = "alu_smoke";
    if (!$value$plusargs("SEED=%d", seed))   seed = 1;
    if (!$value$plusargs("NIGHT=%d", night)) night = 1;
    $display("UVM_INFO @ 0: reporter [RNTST] Running test %0s...", test);
    #10;
    if (test == "alu_smoke" && seed % 5 == 0)
      error("SCBD", "data mismatch on lane 2");
    if (test == "alu_burst" && night == 1)
      error("PROTO", "req asserted while \"busy\" was high");
    if (test == "fifo_full" && seed % 3 == 0)
      error("FIFO", "overflow: wrote 17 entries, depth 16");
    if (test == "csr_access" && night == 2)
      error("CSR", "read of ctrl returned <X> & expected 0x0");
    #10 $display("--- UVM Report Summary ---");
    $display("UVM_ERROR :%5d", n_err);
    $finish;
  end
endmodule

#!/usr/bin/perl
# summarise.pl OUTDIR LOG... -- the regression runner's last step: one
# result record per run, OUTDIR/<run>.tsv, a header line and one row.
# (The verdict and first-error rules are Module 21's, kept minimal here.)
use strict;
use warnings;

my $outdir = shift // die "usage: summarise.pl OUTDIR LOG...\n";
for my $log (@ARGV) {
    my ($run) = $log =~ m{([^/]+)\.log\z} or die "summarise.pl: not a .log: $log\n";
    my ($test, $seed) = $run =~ /^(.+)_s(\d+)\z/ or die "summarise.pl: bad run name: $run\n";
    open my $in, "<", $log or die "summarise.pl: $log: $!\n";
    my ($summary, $first) = (0, undef);
    while (<$in>) {
        $summary = 1 if /^--- UVM Report Summary ---/;
        $first //= "$1: $2" if /^UVM_(?:ERROR|FATAL)\b.*?\[(\w+)\]\s*(.*?)\s*$/;
    }
    close $in;
    my $verdict = !$summary ? "CRASH" : defined $first ? "FAIL" : "PASS";
    open my $out, ">", "$outdir/$run.tsv" or die "summarise.pl: $outdir/$run.tsv: $!\n";
    print {$out} "test\tseed\tverdict\tsignature\n", join("\t", $test, $seed, $verdict, $first // ""), "\n";
    close $out or die "summarise.pl: $outdir/$run.tsv: $!\n";
}

#!/bin/bash
# run_nightly.sh NIGHT DIR -- six tests x eight seeds of night NIGHT's build;
# logs in DIR/logs/, one result record per run in DIR/results/.
set -u
night=${1:?usage: run_nightly.sh NIGHT DIR}; out=${2:?usage: run_nightly.sh NIGHT DIR}
mkdir -p "$out/logs" "$out/results"
iverilog -o "$out/nightly.vvp" tb/tb_nightly.v || exit 1
for test in alu_smoke alu_burst alu_random fifo_basic fifo_full csr_access; do
    for seed in 1 2 3 4 5 6 7 8; do
        vvp -n "$out/nightly.vvp" +TEST=$test +SEED=$seed +NIGHT=$night > "$out/logs/${test}_s$seed.log"
    done
done
rm -f "$out/nightly.vvp"
perl summarise.pl "$out/results" "$out"/logs/*.log

#!/usr/bin/perl
# dashboard.pl -- aggregate one night's per-run result records into one row
# per test, compare with the previous night's CSV, and write a CSV plus a
# self-contained HTML page.
use strict;
use warnings;
use Getopt::Long qw(GetOptions);

use constant { OK => 0, ATTENTION => 1, INPUT => 2, USAGE => 3 };
my @COLUMNS = qw(test runs passed failed pass_rate status top_signature);

my %opt = (csv => "dashboard.csv");
GetOptions(\%opt, "prev=s", "html=s", "csv=s", "title=s", "help") or usage("bad option");
usage() if $opt{help};
usage("need exactly one results directory") unless @ARGV == 1;
my $dir = $ARGV[0];
fail(INPUT, "$dir is not a directory") unless -d $dir;

# ---- read every record; each must have the documented header and one row
my (%by_test, %seen, @problems);
my @files = sort glob("$dir/*.tsv");
push @problems, "no *.tsv result records in $dir" unless @files;
for my $file (@files) {
    open my $fh, "<", $file or fail(INPUT, "$file: $!");
    chomp(my @lines = <$fh>);
    close $fh;
    if (@lines != 2 || $lines[0] ne join("\t", qw(test seed verdict signature))) {
        push @problems, "$file: not a result record (want a header line and one row)";
        next;
    }
    my ($test, $seed, $verdict, $sig) = split /\t/, $lines[1], -1;
    unless (defined $sig && $seed =~ /^\d+\z/ && $verdict =~ /^(?:PASS|FAIL|CRASH)\z/) {
        push @problems, "$file: malformed row: $lines[1]";
        next;
    }
    if (my $first = $seen{"$test $seed"}) {
        push @problems, "$file: $test seed $seed was already read from $first";
        next;
    }
    $seen{"$test $seed"} = $file;
    push @{ $by_test{$test} }, { seed => $seed, verdict => $verdict, sig => $sig };
}

# ---- yesterday, from yesterday's own CSV
my %prev;
if (defined $opt{prev}) {
    open my $fh, "<", $opt{prev} or fail(INPUT, "cannot read --prev $opt{prev}: $!");
    chomp(my $header = <$fh> // "");
    push @problems, "$opt{prev}: header is not: " . join(",", @COLUMNS)
        unless $header eq join(",", @COLUMNS);
    while (my $line = <$fh>) {
        chomp $line;
        my @f = csv_split($line);
        if (!@f) {
            push @problems, "$opt{prev} line $.: cannot be read as CSV (an unbalanced quote?)";
            next;
        }
        if (@f != @COLUMNS) {
            push @problems, "$opt{prev} line $.: " . scalar(@f) . " fields, want " . scalar(@COLUMNS);
            next;
        }
        my %row;
        @row{@COLUMNS} = @f;
        $prev{ $row{test} } = \%row;
    }
    close $fh;
}
if (@problems) {
    print STDERR "dashboard.pl: $_\n" for @problems;
    fail(INPUT, scalar(@problems) . " input problem(s); nothing written");
}

# ---- one row per test: PASS if no run failed, FAIL if none passed, else FLAKY
my @rows;
for my $test (sort keys %by_test) {
    my @runs   = @{ $by_test{$test} };
    my @failed = grep { $_->{verdict} ne "PASS" } @runs;
    my %count;
    $count{ $_->{sig} }++ for @failed;
    my ($top) = sort { $count{$b} <=> $count{$a} or $a cmp $b } keys %count;
    my $passed = @runs - @failed;
    push @rows, { test => $test, runs => scalar @runs, passed => $passed,
                  failed => scalar @failed, pass_rate => rate($passed, scalar @runs),
                  status => !@failed ? "PASS" : !$passed ? "FAIL" : "FLAKY",
                  top_signature => defined $top ? "$top ($count{$top} of " . @failed . ")" : "" };
}

# ---- what changed since yesterday
my %now = map { $_->{test} => $_ } @rows;
my (@newly_failing, @newly_passing, @new_tests, @removed);
for my $t (sort keys %{ { %now, %prev } }) {
    if    (!$prev{$t}) { push @new_tests, $t }
    elsif (!$now{$t})  { push @removed, $t }
    elsif ($prev{$t}{status} eq "PASS" && $now{$t}{status} ne "PASS") { push @newly_failing, $t }
    elsif ($prev{$t}{status} ne "PASS" && $now{$t}{status} eq "PASS") { push @newly_passing, $t }
}
@new_tests = () unless defined $opt{prev};      # with no yesterday, nothing is "new"

# ---- the counts every output below reports, computed BEFORE any of them
my %st;
$st{ $_->{status} }++ for @rows;

# ---- the CSV: quoted where a field needs it, so it reads back exactly
write_atomic($opt{csv}, join("", map { join(",", map { csv_field($_) } @$_) . "\n" }
                                 [@COLUMNS], map { [ @{$_}{@COLUMNS} ] } @rows));

# ---- the HTML page: one file, inline style, every text escaped
write_atomic($opt{html}, html_page()) if defined $opt{html};

printf "%d test(s), %d run(s): PASS %d, FLAKY %d, FAIL %d\n", scalar @rows,
    scalar(keys %seen), map { $st{$_} // 0 } qw(PASS FLAKY FAIL);
if (defined $opt{prev}) {
    printf "%-14s %s\n", "$_->[0]:", @{ $_->[1] } ? join(", ", @{ $_->[1] }) : "none"
        for [ "newly failing", \@newly_failing ], [ "newly passing", \@newly_passing ],
            [ "removed",       \@removed ],       [ "new",           \@new_tests ];
} else {
    print "no --prev: nothing to compare with\n";
}
printf "wrote %s%s\n", $opt{csv}, defined $opt{html} ? " and $opt{html}" : "";
exit(@newly_failing || @removed ? ATTENTION : OK);

# ---------------------------------------------------------------- helpers

# A pass rate rounded DOWN to a tenth, from the counts (Chapter 29.4).
sub rate { my ($n, $d) = @_; my $t = int(1000 * $n / $d); return sprintf "%d.%d", int($t / 10), $t % 10 }

# RFC 4180: quote a field that holds a comma, a quote or a newline, and
# double every quote inside it.
sub csv_field { my ($f) = @_; return $f unless $f =~ /[",\n]/; $f =~ s/"/""/g; return qq{"$f"} }

# The reverse: split one CSV line into fields, honouring quotes.
sub csv_split {
    my ($line) = @_;
    my @f;
    while ($line =~ /\G(?:"((?:[^"]|"")*)"|([^",]*))(,|\z)/gc) {
        # copy the captures first: the s/// below is a match of its own, and
        # a successful match resets $1, $2 and $3
        my ($quoted, $plain, $sep) = ($1, $2, $3);
        push @f, defined $quoted ? ($quoted =~ s/""/"/gr) : $plain;
        last if $sep eq "";
    }
    return pos($line) == length($line) ? @f : ();   # anything left over: malformed
}

sub html { my ($s) = @_; $s =~ s/&/&amp;/g; $s =~ s/</&lt;/g; $s =~ s/>/&gt;/g; $s =~ s/"/&quot;/g; return $s }

sub html_page {
    my $title = html($opt{title} // "Regression dashboard");
    my $list = sub {
        my ($label, @t) = @_;
        return "<h2>" . html($label) . " (" . @t . ")</h2>\n"
             . (@t ? "<ul>\n" . join("", map { "<li>" . html($_) . "</li>\n" } @t) . "</ul>\n"
                   : "<p class=\"none\">none</p>\n");
    };
    my $body = "<h1>$title</h1>\n"
        . sprintf("<p>%d tests, %d runs: %d pass, %d flaky, %d fail</p>\n", scalar @rows,
                  scalar(keys %seen), map { $st{$_} // 0 } qw(PASS FLAKY FAIL));
    $body .= $list->("Newly failing", @newly_failing) . $list->("Newly passing", @newly_passing)
           . $list->("Removed since yesterday", @removed) . $list->("New since yesterday", @new_tests)
        if defined $opt{prev};
    $body .= "<table>\n<tr>" . join("", map { "<th>" . html($_) . "</th>" } @COLUMNS) . "</tr>\n";
    for my $r (@rows) {
        $body .= "<tr class=\"" . lc($r->{status}) . "\">"
               . join("", map { "<td>" . html($r->{$_}) . "</td>" } @COLUMNS) . "</tr>\n";
    }
    $body .= "</table>\n";
    return <<"END";
<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<title>$title</title>
<style>
body { font-family: sans-serif; margin: 2em; color: #1e293b; }
table { border-collapse: collapse; }
th, td { border: 1px solid #cbd5e1; padding: 4px 8px; text-align: left; }
tr.fail td { background: #fee2e2; }
tr.flaky td { background: #fef3c7; }
.none { color: #64748b; }
</style>
</head>
<body>
$body</body>
</html>
END
}

sub write_atomic {
    my ($path, $text) = @_;
    my $tmp = "$path.tmp.$$";
    open my $fh, ">", $tmp or fail(USAGE, "cannot write $tmp: $!");
    print {$fh} $text;
    close $fh or fail(USAGE, "cannot write $tmp: $!");
    rename $tmp, $path or fail(USAGE, "cannot rename $tmp: $!");
}

sub usage {
    my ($why) = @_;
    print STDERR "dashboard.pl: $why\n" if $why;
    print STDERR <<'END';
usage: dashboard.pl RESULTS_DIR [--prev CSV] [--html FILE] [--csv FILE] [--title TEXT]
exit: 0 written; 1 written, and a test is newly failing or was removed;
      2 input problem (nothing written); 3 usage
END
    exit($why ? USAGE : OK);
}

sub fail { my ($code, $msg) = @_; print STDERR "dashboard.pl: $msg\n"; exit $code }

for my $t (sort keys %{ { %now, %prev } }) {
    if    (!$prev{$t}) { push @new_tests, $t }
    elsif (!$now{$t})  { push @removed, $t }
    elsif ($prev{$t}{status} eq "PASS" && $now{$t}{status} ne "PASS") { push @newly_failing, $t }
    elsif ($prev{$t}{status} ne "PASS" && $now{$t}{status} eq "PASS") { push @newly_passing, $t }
}

sub csv_field { my ($f) = @_; return $f unless $f =~ /[",\n]/; $f =~ s/"/""/g; return qq{"$f"} }

    while ($line =~ /\G(?:"((?:[^"]|"")*)"|([^",]*))(,|\z)/gc) {
        # copy the captures first: the s/// below is a match of its own, and
        # a successful match resets $1, $2 and $3
        my ($quoted, $plain, $sep) = ($1, $2, $3);
        push @f, defined $quoted ? ($quoted =~ s/""/"/gr) : $plain;
        last if $sep eq "";
    }

sub html { my ($s) = @_; $s =~ s/&/&amp;/g; $s =~ s/</&lt;/g; $s =~ s/>/&gt;/g; $s =~ s/"/&quot;/g; return $s }

#!/bin/bash
# demo.sh -- two nights of the regression, then a dashboard for each.
bash run_nightly.sh 1 night1 && bash run_nightly.sh 2 night2 || exit 1
echo "$(ls night1/results | wc -l | tr -d ' ') result records a night, e.g. night1/results/fifo_full_s3.tsv:"
cat night1/results/fifo_full_s3.tsv
echo
echo "== night 1"
perl dashboard.pl night1/results --csv night1.csv
echo "exit $?"
echo
echo "== night 2, against night 1"
perl dashboard.pl night2/results --prev night1.csv --csv night2.csv --html report.html --title "Night 2"
echo "exit $?"
echo
cat night2.csv

48 result records a night, e.g. night1/results/fifo_full_s3.tsv:
test	seed	verdict	signature
fifo_full	3	FAIL	FIFO: overflow: wrote 17 entries, depth 16

== night 1
6 test(s), 48 run(s): PASS 3, FLAKY 2, FAIL 1
no --prev: nothing to compare with
wrote night1.csv
exit 0

== night 2, against night 1
6 test(s), 48 run(s): PASS 3, FLAKY 2, FAIL 1
newly failing: csr_access
newly passing: alu_burst
removed:       none
new:           none
wrote night2.csv and report.html
exit 1

test,runs,passed,failed,pass_rate,status,top_signature
alu_burst,8,8,0,100.0,PASS,
alu_random,8,8,0,100.0,PASS,
alu_smoke,8,7,1,87.5,FLAKY,SCBD: data mismatch on lane 2 (1 of 1)
csr_access,8,0,8,0.0,FAIL,CSR: read of ctrl returned <X> & expected 0x0 (8 of 8)
fifo_basic,8,8,0,100.0,PASS,
fifo_full,8,6,2,75.0,FLAKY,"FIFO: overflow: wrote 17 entries, depth 16 (2 of 2)"

#!/bin/bash
# page_html.sh -- the page night 2 produced, exactly as written.
bash run_nightly.sh 1 night1 > /dev/null && bash run_nightly.sh 2 night2 > /dev/null || exit 1
perl dashboard.pl night1/results --csv night1.csv > /dev/null
perl dashboard.pl night2/results --prev night1.csv --csv night2.csv --html report.html --title "Night 2" > /dev/null
cat report.html

<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<title>Night 2</title>
<style>
body { font-family: sans-serif; margin: 2em; color: #1e293b; }
table { border-collapse: collapse; }
th, td { border: 1px solid #cbd5e1; padding: 4px 8px; text-align: left; }
tr.fail td { background: #fee2e2; }
tr.flaky td { background: #fef3c7; }
.none { color: #64748b; }
</style>
</head>
<body>
<h1>Night 2</h1>
<p>6 tests, 48 runs: 3 pass, 2 flaky, 1 fail</p>
<h2>Newly failing (1)</h2>
<ul>
<li>csr_access</li>
</ul>
<h2>Newly passing (1)</h2>
<ul>
<li>alu_burst</li>
</ul>
<h2>Removed since yesterday (0)</h2>
<p class="none">none</p>
<h2>New since yesterday (0)</h2>
<p class="none">none</p>
<table>
<tr><th>test</th><th>runs</th><th>passed</th><th>failed</th><th>pass_rate</th><th>status</th><th>top_signature</th></tr>
<tr class="pass"><td>alu_burst</td><td>8</td><td>8</td><td>0</td><td>100.0</td><td>PASS</td><td></td></tr>
<tr class="pass"><td>alu_random</td><td>8</td><td>8</td><td>0</td><td>100.0</td><td>PASS</td><td></td></tr>
<tr class="flaky"><td>alu_smoke</td><td>8</td><td>7</td><td>1</td><td>87.5</td><td>FLAKY</td><td>SCBD: data mismatch on lane 2 (1 of 1)</td></tr>
<tr class="fail"><td>csr_access</td><td>8</td><td>0</td><td>8</td><td>0.0</td><td>FAIL</td><td>CSR: read of ctrl returned &lt;X&gt; &amp; expected 0x0 (8 of 8)</td></tr>
<tr class="pass"><td>fifo_basic</td><td>8</td><td>8</td><td>0</td><td>100.0</td><td>PASS</td><td></td></tr>
<tr class="flaky"><td>fifo_full</td><td>8</td><td>6</td><td>2</td><td>75.0</td><td>FLAKY</td><td>FIFO: overflow: wrote 17 entries, depth 16 (2 of 2)</td></tr>
</table>
</body>
</html>

#!/bin/bash
# formats.sh -- what the quoting and escaping are for, measured on night 2.
bash run_nightly.sh 1 night1 > /dev/null && bash run_nightly.sh 2 night2 > /dev/null || exit 1
perl dashboard.pl night1/results --csv night1.csv > /dev/null
perl dashboard.pl night2/results --prev night1.csv --csv night2.csv --html report.html > /dev/null

echo "== night2.csv read by a naive split /,/ (the header has 7 columns)"
perl -ne 'chomp; printf "  %d fields  %.46s\n", scalar(my @f = split /,/, $_, -1), $_' night2.csv

echo "== night2.csv given back to the tool as yesterday"
perl dashboard.pl night2/results --prev night2.csv --csv again.csv | sed 's/^/  /'
cmp -s night2.csv again.csv && echo "  the two CSV files are byte-identical"

echo "== the CSR cell, escaped (as written) and raw (as a naive page would write it)"
grep -o '<td>CSR[^/]*</td>' report.html | sed 's/^/  escaped: /'
python3 -c '
from html.parser import HTMLParser
class P(HTMLParser):
    def __init__(s): super().__init__(); s.text = []; s.tags = []
    def handle_data(s, d): s.text.append(d)
    def handle_starttag(s, t, a): s.tags.append(t)
for label, cell in [("escaped", "<td>CSR: read of ctrl returned &lt;X&gt; &amp; expected 0x0</td>"),
                    ("raw    ", "<td>CSR: read of ctrl returned <X> & expected 0x0</td>")]:
    p = P(); p.feed(cell)
    print("  %s -> text %r, elements %s" % (label, "".join(p.text), p.tags))
'

== night2.csv read by a naive split /,/ (the header has 7 columns)
  7 fields  test,runs,passed,failed,pass_rate,status,top_s
  7 fields  alu_burst,8,8,0,100.0,PASS,
  7 fields  alu_random,8,8,0,100.0,PASS,
  7 fields  alu_smoke,8,7,1,87.5,FLAKY,SCBD: data mismatch
  7 fields  csr_access,8,0,8,0.0,FAIL,CSR: read of ctrl re
  7 fields  fifo_basic,8,8,0,100.0,PASS,
  8 fields  fifo_full,8,6,2,75.0,FLAKY,"FIFO: overflow: wr
== night2.csv given back to the tool as yesterday
  6 test(s), 48 run(s): PASS 3, FLAKY 2, FAIL 1
  newly failing: none
  newly passing: none
  removed:       none
  new:           none
  wrote again.csv
  the two CSV files are byte-identical
== the CSR cell, escaped (as written) and raw (as a naive page would write it)
  escaped: <td>CSR: read of ctrl returned &lt;X&gt; &amp; expected 0x0 (8 of 8)</td>
  escaped -> text 'CSR: read of ctrl returned <X> & expected 0x0', elements ['td']
  raw     -> text 'CSR: read of ctrl returned  & expected 0x0', elements ['td', 'x']

#!/bin/bash
# edges.sh -- a test that stopped running, and inputs the tool must refuse.
bash run_nightly.sh 1 night1 > /dev/null && bash run_nightly.sh 2 night2 > /dev/null || exit 1
perl dashboard.pl night1/results --csv night1.csv > /dev/null
try() {   # LABEL RESULTS-DIR [ARGS]
    local label=$1; shift
    perl dashboard.pl "$@" --csv out.csv > out.txt 2> err.txt
    local rc=$?
    echo "== $label"
    grep -E '^(newly|removed|new:|no --prev)' out.txt | sed 's/^/   /'
    grep -v -E '^(usage:|exit:|      )' err.txt | sed 's/^/   /'
    echo "   exit $rc, csv written: $([ -e out.csv ] && echo yes || echo no)"
    rm -f out.csv
}
try "night 1, the first night"        night1/results
try "night 2 against night 1"         night2/results --prev night1.csv
mkdir -p shrunk && cp night2/results/*.tsv shrunk/ && rm shrunk/fifo_basic_s*.tsv
try "night 2 with fifo_basic not run" shrunk --prev night1.csv
mkdir -p empty
try "no result records"               empty
mkdir -p dup && cp night2/results/*.tsv dup/ && cp dup/alu_smoke_s5.tsv dup/alu_smoke_s5_rerun.tsv
try "a run recorded twice"            dup
mkdir -p old && cp night2/results/*.tsv old/ && printf 'alu_smoke 9 PASS\n' > old/alu_smoke_s9.tsv
try "a record in an older layout"     old
sed '1s/,top_signature$//' night1.csv > v1.csv
try "yesterday from an older version" night2/results --prev v1.csv
sed 's/"PROTO: req/"PROTO req/; s/high (8 of 8)"$/high (8 of 8)/' night1.csv > cut.csv
try "yesterday with a broken quote"   night2/results --prev cut.csv

== night 1, the first night
   no --prev: nothing to compare with
   exit 0, csv written: yes
== night 2 against night 1
   newly failing: csr_access
   newly passing: alu_burst
   removed:       none
   new:           none
   exit 1, csv written: yes
== night 2 with fifo_basic not run
   newly failing: csr_access
   newly passing: alu_burst
   removed:       fifo_basic
   new:           none
   exit 1, csv written: yes
== no result records
   dashboard.pl: no *.tsv result records in empty
   dashboard.pl: 1 input problem(s); nothing written
   exit 2, csv written: no
== a run recorded twice
   dashboard.pl: dup/alu_smoke_s5_rerun.tsv: alu_smoke seed 5 was already read from dup/alu_smoke_s5.tsv
   dashboard.pl: 1 input problem(s); nothing written
   exit 2, csv written: no
== a record in an older layout
   dashboard.pl: old/alu_smoke_s9.tsv: not a result record (want a header line and one row)
   dashboard.pl: 1 input problem(s); nothing written
   exit 2, csv written: no
== yesterday from an older version
   dashboard.pl: v1.csv: header is not: test,runs,passed,failed,pass_rate,status,top_signature
   dashboard.pl: 1 input problem(s); nothing written
   exit 2, csv written: no
== yesterday with a broken quote
   dashboard.pl: cut.csv line 2: cannot be read as CSV (an unbalanced quote?)
   dashboard.pl: 1 input problem(s); nothing written
   exit 2, csv written: no

#!/usr/bin/perl
# t/dashboard.t -- black-box tests over two real nights of simulation.
use strict;
use warnings;
use Test::More;
use File::Temp qw(tempdir);
use File::Copy qw(copy);
use FindBin qw($Bin);

my $TOOL = "$Bin/../dashboard.pl";
my $base = tempdir(CLEANUP => 1);
chdir "$Bin/.." or die;
for my $n (1, 2) {
    system("bash run_nightly.sh $n $base/night$n > /dev/null") == 0 or die "night $n failed\n";
}
my ($N1, $N2) = ("$base/night1/results", "$base/night2/results");

sub slurp { open my $fh, "<", $_[0] or return undef; local $/; return scalar <$fh> }
sub spew  { open my $fh, ">", $_[0] or die "$_[0]: $!"; print {$fh} $_[1]; close $fh }
sub run_tool {      # (status, stdout, stderr)
    my @args = @_;
    my $pid = fork // die "fork: $!";
    if ($pid == 0) {
        open STDOUT, ">", "$base/stdout" or die;
        open STDERR, ">", "$base/stderr" or die;
        exec $^X, $TOOL, @args;
        die "exec: $!";
    }
    waitpid $pid, 0;
    return ($? >> 8, slurp("$base/stdout") // "", slurp("$base/stderr") // "");
}
sub copy_dir { my ($from, $to) = @_; mkdir $to or die; copy($_, $to) or die for glob("$from/*.tsv"); return $to }

# ---- night 1: aggregation
my ($rc, $out) = run_tool($N1, "--csv", "$base/n1.csv");
ok($rc == 0 && $out =~ /PASS 3, FLAKY 2, FAIL 1/, "night 1: exit 0; 3 pass, 2 flaky, 1 fail");
my (%pass, %fail);       # counted here from the records, not by the tool
for my $f (glob("$N1/*.tsv")) {
    my (undef, $row) = split /\n/, slurp($f);
    my ($test, undef, $verdict) = split /\t/, $row;
    $verdict eq "PASS" ? $pass{$test}++ : $fail{$test}++;
}
my %csv = map { /^([^,]+),\d+,(\d+),(\d+),/ ? ($1 => [ $2, $3 ]) : () } split /\n/, slurp("$base/n1.csv");
is_deeply(\%csv, { map { $_ => [ $pass{$_} // 0, $fail{$_} // 0 ] } keys %{ { %pass, %fail } } },
          "every test's passed and failed counts equal the records'");
like(slurp("$base/n1.csv"), qr/^alu_burst,8,0,8,0\.0,FAIL,"PROTO: req asserted while ""busy"" was high \(8 of 8\)"$/m,
     "a quote inside a field is doubled, and the field quoted");

# ---- night 2 against night 1
my $err;
($rc, $out, $err) = run_tool($N2, "--prev", "$base/n1.csv", "--csv", "$base/n2.csv",
                             "--html", "$base/r.html");
ok($rc == 1 && $out =~ /^newly failing: csr_access$/m && $out =~ /^newly passing: alu_burst$/m,
   "night 2: csr_access newly failing, alu_burst newly passing, exit 1");
is($err, "", "reading night 1's CSV, with its doubled quotes, gives no warning");
like(slurp("$base/n2.csv"), qr/^fifo_full,8,6,2,75\.0,FLAKY,"FIFO: overflow: wrote 17 entries, depth 16 \(2 of 2\)"$/m,
     "a comma inside a field is quoted");
my ($rc_rt, $out_rt, $err_rt) = run_tool($N2, "--prev", "$base/n2.csv", "--csv", "$base/again.csv");
ok($rc_rt == 0 && $out_rt =~ /^newly failing: none$/m && $err_rt eq "",
   "the tool reads its own CSV back: no changes, nothing on STDERR");
is(slurp("$base/again.csv"), slurp("$base/n2.csv"), "and writes it again byte for byte");

# ---- the HTML page
my $html = slurp("$base/r.html");
like($html, qr/<p>6 tests, 48 runs: 3 pass, 2 flaky, 1 fail<\/p>/, "the page's counts match the CSV");
ok($html =~ /returned &lt;X&gt; &amp; expected/ && $html !~ /<X>/, "message text is escaped, never raw");
ok($html !~ /<script|<link|\bsrc=|https?:/i, "the page is self-contained: no scripts, links or URLs");
run_tool($N2, "--prev", "$base/n1.csv", "--csv", "$base/n2b.csv", "--html", "$base/r2.html");
is(slurp("$base/r2.html"), $html, "a second run writes the identical page");

# ---- a test that goes from PASS to FLAKY is newly failing
my $flaky = copy_dir($N1, "$base/flaky");
(my $rec = slurp("$flaky/alu_random_s4.tsv")) =~ s/\tPASS\t$/\tFAIL\tSCBD: one bad seed/m or die;
spew("$flaky/alu_random_s4.tsv", $rec);
(undef, $out) = run_tool($flaky, "--prev", "$base/n1.csv", "--csv", "$base/f.csv");
like($out, qr/^newly failing: alu_random$/m, "PASS yesterday, FLAKY today: newly failing");

# ---- a pass rate is rounded down
my $three = "$base/three";
mkdir $three or die;
spew("$three/t_s$_->[0].tsv", "test\tseed\tverdict\tsignature\nt\t$_->[0]\t$_->[1]\t$_->[2]\n")
    for [1, "PASS", ""], [2, "PASS", ""], [3, "FAIL", "X: y"];
run_tool($three, "--csv", "$base/three.csv");
like(slurp("$base/three.csv"), qr/^t,3,2,1,66\.6,FLAKY,/m, "2 of 3 is 66.6, not 66.7");

# ---- a test that stopped running is reported, not forgotten
my $shrunk = copy_dir($N2, "$base/shrunk");
unlink glob("$shrunk/fifo_basic_s*.tsv");
($rc, $out) = run_tool($shrunk, "--prev", "$base/n1.csv", "--csv", "$base/s.csv");
ok($rc == 1 && $out =~ /^removed:\s+fifo_basic$/m, "a test that was not run today is listed as removed");

# ---- input problems: exit 2 and nothing written
my $dup = copy_dir($N2, "$base/dup");
copy("$dup/alu_smoke_s5.tsv", "$dup/alu_smoke_s5_rerun.tsv") or die;
my $old = copy_dir($N2, "$base/old");
spew("$old/alu_smoke_s9.tsv", "alu_smoke 9 PASS\n");
(my $v1 = slurp("$base/n1.csv")) =~ s/,top_signature$//m;
spew("$base/v1.csv", $v1);
(my $cut = slurp("$base/n1.csv")) =~ s/high \(8 of 8\)"$/high (8 of 8)/m;
spew("$base/cut.csv", $cut);
mkdir "$base/empty" or die;
for my $c ([ "a run recorded twice", [ $dup ], qr/already read/ ],
           [ "a record in another layout", [ $old ], qr/not a result record/ ],
           [ "yesterday from an older version", [ $N2, "--prev", "$base/v1.csv" ], qr/header is not/ ],
           [ "yesterday with a broken quote", [ $N2, "--prev", "$base/cut.csv" ], qr/unbalanced quote/ ],
           [ "no records at all", [ "$base/empty" ], qr/no \*\.tsv/ ]) {
    my ($label, $args, $why) = @$c;
    unlink "$base/x.csv";
    my ($crc, undef, $cerr) = run_tool(@$args, "--csv", "$base/x.csv");
    ok($crc == 2 && $cerr =~ $why && !-e "$base/x.csv", "$label: exit 2, explained, nothing written");
}
($rc) = run_tool();
is($rc, 3, "no results directory: exit 3");

done_testing();

#!/bin/bash
# tests.sh -- run the suite through prove, keeping prove's own exit status.
prove -v t/ > prove.log 2>&1
status=$?
grep -v 'wallclock' prove.log
echo "prove exit $status"

t/dashboard.t .. 
ok 1 - night 1: exit 0; 3 pass, 2 flaky, 1 fail
ok 2 - every test's passed and failed counts equal the records'
ok 3 - a quote inside a field is doubled, and the field quoted
ok 4 - night 2: csr_access newly failing, alu_burst newly passing, exit 1
ok 5 - reading night 1's CSV, with its doubled quotes, gives no warning
ok 6 - a comma inside a field is quoted
ok 7 - the tool reads its own CSV back: no changes, nothing on STDERR
ok 8 - and writes it again byte for byte
ok 9 - the page's counts match the CSV
ok 10 - message text is escaped, never raw
ok 11 - the page is self-contained: no scripts, links or URLs
ok 12 - a second run writes the identical page
ok 13 - PASS yesterday, FLAKY today: newly failing
ok 14 - 2 of 3 is 66.6, not 66.7
ok 15 - a test that was not run today is listed as removed
ok 16 - a run recorded twice: exit 2, explained, nothing written
ok 17 - a record in another layout: exit 2, explained, nothing written
ok 18 - yesterday from an older version: exit 2, explained, nothing written
ok 19 - yesterday with a broken quote: exit 2, explained, nothing written
ok 20 - no records at all: exit 2, explained, nothing written
ok 21 - no results directory: exit 3
1..21
ok
All tests successful.
Result: PASS
prove exit 0

#!/bin/bash
# mutate.sh -- plant one defect at a time in a COPY of the tool; does the
# suite notice?
mutant() {   # LABEL PERL-SUBSTITUTION (applied to the whole file)
    local label=$1 edit=$2 d failed
    d=$(mktemp -d)
    mkdir "$d/t"
    cp -r run_nightly.sh summarise.pl tb "$d/"
    cp t/dashboard.t "$d/t/"
    perl -0pe "$edit" dashboard.pl > "$d/dashboard.pl"
    if cmp -s dashboard.pl "$d/dashboard.pl"; then
        printf '%-44s NOT PLANTED (edit matched nothing)\n' "$label"
    elif ! perl -c "$d/dashboard.pl" > /dev/null 2>&1; then
        printf '%-44s INVALID (the mutant does not compile)\n' "$label"
    else
        failed=$(perl "$d/t/dashboard.t" 2>/dev/null | grep -c '^not ok')
        printf '%-44s %s (%s failing test(s))\n' "$label" \
            "$([ "$failed" -gt 0 ] && echo CAUGHT || echo SURVIVED)" "$failed"
    fi
    rm -rf "$d"
}
mutant "1 count statuses after the page is built" \
    's/(my %st;\n)(\$st\{ \$_->\{status\} \}\+\+ for \@rows;\n)(.*?\n)(printf "%d test)/$1$3$2$4/s'
mutant "2 write CSV fields without quoting"   's/return \$f unless \$f =~ \/\[",\\n\]\/;/return \$f;/'
mutant "3 write HTML text without escaping"   's/sub html \{ my \(\$s\) = \@_; /sub html { my (\$s) = \@_; return \$s; /'
mutant "4 read captures after the s///"       's/my \(\$quoted, \$plain, \$sep\) = \(\$1, \$2, \$3\);\n\s+push \@f, defined \$quoted \? \(\$quoted =~ s\/""\/"\/gr\) : \$plain;\n\s+last if \$sep eq "";/push \@f, defined \$1 ? (\$1 =~ s\/""\/"\/gr) : \$2;\n        last if \$3 eq "";/'
mutant "5 any failing run makes a test FAIL"  's/!\$passed \? "FAIL" : "FLAKY"/"FAIL"/'
mutant "6 forget tests that stopped running"  's/elsif \(!\$now\{\$t\}\)  \{ push \@removed, \$t \}/elsif (!\$now{\$t}) { }/'
mutant "7 round the pass rate to nearest"     's/my \$t = int\(1000 \* \$n \/ \$d\);/my \$t = int(1000 * \$n \/ \$d + 0.5);/'
mutant "8 only FAIL counts as newly failing"  's/\$now\{\$t\}\{status\} ne "PASS"\) \{ push \@newly_failing/\$now{\$t}{status} eq "FAIL") { push \@newly_failing/'

1 count statuses after the page is built     CAUGHT (1 failing test(s))
2 write CSV fields without quoting           CAUGHT (9 failing test(s))
3 write HTML text without escaping           CAUGHT (1 failing test(s))
4 read captures after the s///               CAUGHT (1 failing test(s))
5 any failing run makes a test FAIL          CAUGHT (4 failing test(s))
6 forget tests that stopped running          CAUGHT (1 failing test(s))
7 round the pass rate to nearest             CAUGHT (1 failing test(s))
8 only FAIL counts as newly failing          CAUGHT (1 failing test(s))