Generating HTML Without a Framework

sub esc { my ($s) = @_; $s =~ s/&/&amp;/g; $s =~ s/</&lt;/g; return $s }

sub esc_text { ... & then < then > ... }
sub esc_attr { esc_text, then " and ' }

use strict;
use warnings;

# ---- the registry's sketch, and a complete escaper
sub esc_sketch {                      # & and < only
    my ($s) = @_;
    $s =~ s/&/&amp;/g;
    $s =~ s/</&lt;/g;
    return $s;
}
sub esc_wrong_order {                 # the same two, the other way round
    my ($s) = @_;
    $s =~ s/</&lt;/g;
    $s =~ s/&/&amp;/g;
    return $s;
}
sub esc_text {                        # safe in element text
    my ($s) = @_;
    $s = "" unless defined $s;
    $s =~ s/&/&amp;/g;                # FIRST, always
    $s =~ s/</&lt;/g;
    $s =~ s/>/&gt;/g;
    return $s;
}
sub esc_attr {                        # safe inside a quoted attribute
    my ($s) = @_;
    $s = esc_text($s);
    $s =~ s/"/&quot;/g;
    $s =~ s/'/&#39;/g;
    return $s;
}

# values a tool log, a path or a message can really contain. TEST VECTORS,
# not data from this corpus -- none of these characters appears in it, which
# is exactly why an escaper cannot be judged on one corpus.
my @VECTORS = (
    "arb_smoke",
    "a < b",
    "a > b",
    "x && y",
    'say "hi"',
    "it's fine",
    "&amp;",
    "<script>alert(1)</script>",
    "/path/to/<unknown>/run",
    "assign q <= d;",
    "100% & rising",
    "",
);

printf "%-28s %-30s %s\n", "VALUE", "esc_text", "VERDICT";
my ($ok, $bad) = (0, 0);
for my $v (@VECTORS) {
    my $e = esc_text($v);
    # a correctly escaped string has no bare <, > or & left
    my $clean = $e !~ /[<>]/ && $e !~ /&(?!amp;|lt;|gt;|quot;|#39;)/;
    $clean ? $ok++ : $bad++;
    printf "%-28s %-30s %s\n", $v eq "" ? "(empty)" : $v, $e,
        $clean ? "ok" : "STILL UNSAFE";
}
printf "\n%d of %d escaped safely for element text\n", $ok, $ok + $bad;

# ---- 1. the order of the substitutions
print "\n==== the order of the substitutions ====\n";
printf "%-18s %-22s %-22s %s\n", "VALUE", "& FIRST", "< FIRST", "";
for my $v ("a < b", "&amp;", "x && y") {
    my $right = esc_sketch($v);
    my $wrong = esc_wrong_order($v);
    printf "%-18s %-22s %-22s %s\n", $v, $right, $wrong,
        $right eq $wrong ? "same" : "DIFFER";
}
print "escaping < before & turns the & of &lt; into &amp;lt;, so the page\n";
print "shows the entity instead of the character. & must go first.\n";

# ---- 2. escaping twice
print "\n==== escaping the same value twice ====\n";
for my $v ("a < b", "&amp;") {
    my $once  = esc_text($v);
    my $twice = esc_text($once);
    printf "  %-10s once: %-20s twice: %-24s %s\n", $v, $once, $twice,
        $once eq $twice ? "idempotent" : "DOUBLE ESCAPED";
}
print "so escape exactly once, at the point of output. A value escaped in a\n";
print "helper and escaped again in the printer shows &amp;lt; to the reader.\n";

# ---- 3. the attribute context needs more
print "\n==== text against attribute ====\n";
my $title = 'the "arb_light" run';
printf "value              : %s\n", $title;
printf "in element text    : <td>%s</td>\n", esc_text($title);
printf "in an attribute    : <td title=\"%s\">\n", esc_text($title);
printf "with esc_attr      : <td title=\"%s\">\n", esc_attr($title);
my $broken = sprintf '<td title="%s">', esc_text($title);
my $attrs  = () = $broken =~ /"/g;
printf "quotes in the attribute line: %d -- %s\n", $attrs,
    $attrs == 2 ? "balanced" : "the attribute ends early, and the rest leaks into markup";

# ---- 4. the page, and a structural check of it
print "\n==== the generated page ====\n";
my %RANK = (FAIL => 0, TIMEOUT => 1, UNKNOWN => 2, PASS => 3);
sub read_log {
    my ($path) = @_;
    my %r = (log => $path, verdict => "UNKNOWN", errors => 0,
             complete => 0, budget => 0);
    open my $fh, "<", $path or return \%r;
    while (my $l = <$fh>) {
        $r{test}    = $1 if $l =~ /^TEST:\s+(\S+)/;
        $r{seed}    = $1 if $l =~ /^SEED:\s+(\d+)/;
        $r{simtime} = $1 if $l =~ /^SIMTIME:\s+(\d+)/;
        $r{budget}  = 1  if $l =~ /^UVM_FATAL\s.*\[BUDGET\]/;
        if ($l =~ /^UVM_ERROR\s+\S+\(\d+\)/) {
            $r{msg}++;
            $r{first_id} = $1 if !defined $r{first_id} && $l =~ /\[(\w+)\]/;
        }
        $r{complete} = 1 if $l =~ /^\*\* Report counts by severity/;
        $r{sum}     = $1 if $l =~ /^UVM_ERROR\s*:\s*(\d+)/;
        $r{verdict} = "PASS" if $l =~ /^TEST PASSED/;
        $r{verdict} = "FAIL" if $l =~ /^TEST FAILED/;
    }
    close $fh;
    $r{errors}  = $r{complete} ? $r{sum} : ($r{msg} || 0);
    $r{verdict} = "TIMEOUT" if $r{budget} && $r{verdict} eq "UNKNOWN";
    return \%r;
}
my @recs = grep { defined $_->{test} } map { read_log($_) } sort glob("logs/*.log");

my @COLS = ("test", "seed", "verdict", "errors", "simtime", "first_id", "log");
open my $out, ">", "report.html" or die $!;
print {$out} <<'HEAD';
<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<title>Nightly regression</title>
<style>
 body  { font: 14px/1.5 system-ui, sans-serif; margin: 2rem; color: #0f172a }
 table { border-collapse: collapse; font-variant-numeric: tabular-nums }
 th,td { border-bottom: 1px solid #e2e8f0; padding: .35rem .7rem; text-align: left }
 th    { background: #f8fafc; font-weight: 600 }
 tr:nth-child(even) td { background: #fcfdfe }
 .FAIL    { color: #b91c1c; font-weight: 600 }
 .TIMEOUT { color: #b45309; font-weight: 600 }
 .UNKNOWN { color: #6b7280 }
 .PASS    { color: #15803d }
 td.n  { text-align: right }
</style>
</head>
<body>
HEAD
printf {$out} "<h1>Nightly regression</h1>\n";
printf {$out} "<p>%d runs, sorted worst first. No JavaScript, so this page\n" .
              "opens from a file link and inside a mail client.</p>\n", scalar @recs;
print {$out} "<table>\n<tr>";
printf {$out} "<th>%s</th>", esc_text($_) for @COLS;
print {$out} "</tr>\n";
for my $r (sort { $RANK{$a->{verdict}} <=> $RANK{$b->{verdict}}
                    or $a->{test} cmp $b->{test}
                    or $a->{seed} <=> $b->{seed} } @recs) {
    print {$out} "<tr>";
    for my $c (@COLS) {
        my $v = $r->{$c};
        my $num = $c =~ /^(seed|errors|simtime)$/ ? ' class="n"' : "";
        if ($c eq "verdict") {
            printf {$out} '<td class="%s">%s</td>', esc_attr($v), esc_text($v);
        } else {
            printf {$out} "<td%s>%s</td>", $num,
                defined $v ? esc_text($v) : "&mdash;";
        }
    }
    print {$out} "</tr>\n";
}
print {$out} "</table>\n</body>\n</html>\n";
close $out;

open my $in, "<", "report.html" or die $!;
my $html = do { local $/; <$in> };
close $in;
printf "report.html written: %d bytes, %d lines\n",
    length $html, scalar split /\n/, $html;
# structural checks, since no HTML parser is available here
for my $tag (qw(table tr th td)) {
    my $open  = () = $html =~ /<$tag\b/g;
    my $close = () = $html =~ m{</$tag>}g;
    printf "  <%-5s open %4d  close %4d  %s\n", $tag . ">", $open, $close,
        $open == $close ? "balanced" : "UNBALANCED";
}
my $rows = () = $html =~ /<tr>/g;
printf "  rows: %d = 1 header + %d data\n", $rows, $rows - 1;
printf "  rows match the record count: %s\n",
    $rows - 1 == @recs ? "yes" : "NO";
# no bare < or & may survive outside a tag
my $text = $html;
$text =~ s/<[^>]*>//g;
my @bare_lt = $text =~ /</g;
my @bare_amp = $text =~ /&(?!amp;|lt;|gt;|quot;|mdash;|#39;)/g;
printf "  bare '<' in text: %d   bare '&' in text: %d\n",
    scalar @bare_lt, scalar @bare_amp;

# ---- 5. what a READER sees when a value is NOT escaped.
# No Perl HTML parser is installed here and a parser cannot validate itself,
# so this asks an independent oracle: tools/html_oracle.py, which uses
# Python's html.parser and therefore the same lenient recovery a browser does.
print "\n==== an unescaped value, as a browser would read it ====\n";
sub oracle_text {
    my ($v) = @_;
    my @out = `python3 -I tools/html_oracle.py text '$v' 2>/dev/null`;
    my %f;
    for (@out) { chomp; my ($k, $val) = split /\t/, $_, 2; $f{$k} = $val // "" }
    return \%f;
}
printf "%-18s %-20s %-10s %s\n", "SOURCE TEXT", "WHAT A READER SEES",
    "BOGUS TAG", "VERDICT";
my ($recovered, $corrupted) = (0, 0);
for my $v ("a < b", "a <b", "x<y", "q <= d", "q<=d", "<unknown>",
           "x && y", "100% & rising") {
    my $o = oracle_text($v);
    $o->{VERDICT} eq "recovered" ? $recovered++ : $corrupted++;
    printf "%-18s %-20s %-10s %s\n", $v,
        $o->{VISIBLE} eq "" ? "(nothing)" : $o->{VISIBLE},
        $o->{BOGUS} eq "" ? "-" : $o->{BOGUS}, $o->{VERDICT};
}
printf "\n%d recovered, %d CORRUPTED\n", $recovered, $corrupted;
print "the rule is narrow: a '<' followed by a LETTER starts a tag, so\n";
print "'a < b' survives and 'a <b' loses the rest of the field. '<unknown>',\n";
print "an ordinary thing in a tool log, disappears completely.\n";
print "That narrowness is why unescaped output survives review: most values\n";
print "look right, and the ones that vanish do it silently.\n";

# ---- 6. the oracle on the generated page
print "\n==== the oracle on report.html ====\n";
my %f;
for (`python3 -I tools/html_oracle.py file report.html 2>/dev/null`) {
    chomp; my ($k, $v) = split /\t/, $_, 2; $f{$k} = $v;
}
printf "  elements   : %s\n", $f{ELEMENTS};
printf "  end tags   : %s   (one fewer: <meta> is void)\n", $f{ENDTAGS};
printf "  table rows : %s   = 1 header + %d data\n", $f{ROWS}, $f{ROWS} - 1;
printf "  cells      : %s   = %d rows x %d columns\n", $f{CELLS},
    $f{ROWS} - 1, scalar @COLS;
printf "  raw '<' in text: %s   raw '>' in text: %s\n", $f{RAW_LT}, $f{RAW_GT};
printf "  rows match the record count: %s\n",
    $f{ROWS} - 1 == @recs ? "yes" : "NO";

# ---- 7. the installed validators, and their exit statuses
print "\n==== tidy and xmllint ====\n";
# a page broken in one place: the sketch escaper used inside an attribute
my $t = 'the "arb_light" run';
open my $bo, ">", "broken.html" or die $!;
printf {$bo} "<!doctype html>\n<html lang=\"en\">\n<head><title>t</title></head>\n"
           . "<body>\n<table>\n<tr><td title=\"%s\">x</td></tr>\n</table>\n"
           . "</body>\n</html>\n", esc_sketch($t);
close $bo;
# two pages with a raw '<' in element text: one followed by a space, one by
# a letter. They are not the same hazard.
for my $pair (["rawlt_space.html", "a < b"], ["rawlt_letter.html", "a <b"]) {
    my ($file, $body) = @$pair;
    open my $ro, ">", $file or die $!;
    print {$ro} "<!doctype html>\n<html lang=\"en\">\n<head><title>t</title></head>\n"
              . "<body>\n<p>$body</p>\n</body>\n</html>\n";
    close $ro;
}
printf "%-18s %-20s %-20s %s\n", "PAGE", "tidy", "xmllint", "raw '<' in text";
for my $page (qw(report.html broken.html rawlt_space.html rawlt_letter.html)) {
    my @tl = `tidy -q -e $page 2>&1`;
    my $trc = $? >> 8;
    my $tw  = grep { /Warning|Error/ } @tl;
    my @xl = `xmllint --noout --html $page 2>&1`;
    my $xrc = $? >> 8;
    my $xe  = grep { /error/i } @xl;
    my %o;
    for (`python3 -I tools/html_oracle.py file $page 2>/dev/null`) {
        chomp; my ($k, $v) = split /\t/, $_, 2; $o{$k} = $v;
    }
    printf "%-18s %-20s %-20s %s\n", $page,
        sprintf("rc=%d, %d msg", $trc, $tw),
        sprintf("rc=%d, %d err", $xrc, $xe),
        $o{RAW_LT} // "?";
}
print "\nneither exit status is usable. tidy returns 1 for the CORRECT page --\n";
print "its messages are HTML4-era notes about <meta charset> and summary= --\n";
print "and xmllint returns 0 even for a page it has just reported an error on.\n";
print "\nand look at the last column. The corrupted page reports ZERO raw '<'\n";
print "in text, because the '<b' was swallowed INTO a tag and never reached\n";
print "the text at all. Counting raw '<' is the wrong gate: it is zero both\n";
print "when the page is right and when the damage has already happened.\n";

# ---- 8. the gate that does work: a round trip through the page
print "\n==== the gate that works: a round trip ====\n";
sub page_text {
    my ($page) = @_;
    for (`python3 -I tools/html_oracle.py file $page 2>/dev/null`) {
        chomp;
        my ($k, $v) = split /\t/, $_, 2;
        return $v // "" if $k eq "TEXT";
    }
    return "";
}
my $seen = page_text("report.html");
my @missing = grep { index($seen, $_) < 0 }
              do { my %u; $u{ $_->{test} } = 1 for @recs; sort keys %u };
printf "test names written into the page : %d\n",
    scalar do { my %u; $u{ $_->{test} } = 1 for @recs; keys %u };
printf "test names a reader can see      : %d\n",
    scalar do { my %u; $u{ $_->{test} } = 1 for @recs; keys %u } - @missing;
printf "missing from the visible text    : %d%s\n", scalar @missing,
    @missing ? " (" . join(" ", @missing) . ")" : "";
my $lost = page_text("rawlt_letter.html");
printf "\nthe same check on the corrupted page: wrote 'a <b', reader sees '%s'\n",
    $lost;
printf "round trip: %s\n", $lost eq "a <b" ? "intact" : "VALUE LOST";
print "\nso the gate is: every value written into the page must be findable in\n";
print "the page's visible text. That is the same round-trip rule as 24.8, and\n";
print "it is the only check here that fires on the damage rather than on a\n";
print "character that the damage removes.\n";

VALUE                        esc_text                       VERDICT
arb_smoke                    arb_smoke                      ok
a < b                        a &lt; b                       ok
a > b                        a &gt; b                       ok
x && y                       x &amp;&amp; y                 ok
say "hi"                     say "hi"                       ok
it's fine                    it's fine                      ok
&amp;                        &amp;amp;                      ok
<script>alert(1)</script>    &lt;script&gt;alert(1)&lt;/script&gt; ok
/path/to/<unknown>/run       /path/to/&lt;unknown&gt;/run   ok
assign q <= d;               assign q &lt;= d;              ok
100% & rising                100% &amp; rising              ok
(empty)                                                     ok

12 of 12 escaped safely for element text

==== the order of the substitutions ====
VALUE              & FIRST                < FIRST                
a < b              a &lt; b               a &amp;lt; b           DIFFER
&amp;              &amp;amp;              &amp;amp;              same
x && y             x &amp;&amp; y         x &amp;&amp; y         same
escaping < before & turns the & of &lt; into &amp;lt;, so the page
shows the entity instead of the character. & must go first.

==== escaping the same value twice ====
  a < b      once: a &lt; b             twice: a &amp;lt; b             DOUBLE ESCAPED
  &amp;      once: &amp;amp;            twice: &amp;amp;amp;            DOUBLE ESCAPED
so escape exactly once, at the point of output. A value escaped in a
helper and escaped again in the printer shows &amp;lt; to the reader.

==== text against attribute ====
value              : the "arb_light" run
in element text    : <td>the "arb_light" run</td>
in an attribute    : <td title="the "arb_light" run">
with esc_attr      : <td title="the &quot;arb_light&quot; run">
quotes in the attribute line: 4 -- the attribute ends early, and the rest leaks into markup

==== the generated page ====
report.html written: 7000 bytes, 63 lines
  <table> open    1  close    1  balanced
  <tr>   open   37  close   37  balanced
  <th>   open    7  close    7  balanced
  <td>   open  252  close  252  balanced
  rows: 37 = 1 header + 36 data
  rows match the record count: yes
  bare '<' in text: 0   bare '&' in text: 0

==== an unescaped value, as a browser would read it ====
SOURCE TEXT        WHAT A READER SEES   BOGUS TAG  VERDICT
a < b              a < b                -          recovered
a <b               a                    b<         CORRUPTED
x<y                x                    y<         CORRUPTED
q <= d             q <= d               -          recovered
q<=d               q<=d                 -          recovered
<unknown>          (nothing)            unknown    CORRUPTED
x && y             x && y               -          recovered
100% & rising      100% & rising        -          recovered

5 recovered, 3 CORRUPTED
the rule is narrow: a '<' followed by a LETTER starts a tag, so
'a < b' survives and 'a <b' loses the rest of the field. '<unknown>',
an ordinary thing in a tool log, disappears completely.
That narrowness is why unescaped output survives review: most values
look right, and the ones that vanish do it silently.

==== the oracle on report.html ====
  elements   : 305
  end tags   : 304   (one fewer: <meta> is void)
  table rows : 37   = 1 header + 36 data
  cells      : 252   = 36 rows x 7 columns
  raw '<' in text: 0   raw '>' in text: 0
  rows match the record count: yes

==== tidy and xmllint ====
PAGE               tidy                 xmllint              raw '<' in text
report.html        rc=1, 4 msg          rc=0, 0 err          0
broken.html        rc=1, 3 msg          rc=0, 2 err          0
rawlt_space.html   rc=0, 0 msg          rc=0, 1 err          1
rawlt_letter.html  rc=1, 3 msg          rc=0, 2 err          0

neither exit status is usable. tidy returns 1 for the CORRECT page --
its messages are HTML4-era notes about <meta charset> and summary= --
and xmllint returns 0 even for a page it has just reported an error on.

and look at the last column. The corrupted page reports ZERO raw '<'
in text, because the '<b' was swallowed INTO a tag and never reached
the text at all. Counting raw '<' is the wrong gate: it is zero both
when the page is right and when the damage has already happened.

==== the gate that works: a round trip ====
test names written into the page : 9
test names a reader can see      : 9
missing from the visible text    : 0

the same check on the corrupted page: wrote 'a <b', reader sees 't a'
round trip: VALUE LOST

so the gate is: every value written into the page must be findable in
the page's visible text. That is the same round-trip rule as 24.8, and
it is the only check here that fires on the damage rather than on a
character that the damage removes.

VALUE              & FIRST                < FIRST
a < b              a &lt; b               a &amp;lt; b           DIFFER

  a < b      once: a &lt; b             twice: a &amp;lt; b             DOUBLE ESCAPED
  &amp;      once: &amp;amp;            twice: &amp;amp;amp;            DOUBLE ESCAPED

value              : the "arb_light" run
in element text    : <td>the "arb_light" run</td>
in an attribute    : <td title="the "arb_light" run">
with esc_attr      : <td title="the &quot;arb_light&quot; run">
quotes in the attribute line: 4 -- the attribute ends early, and the rest leaks into markup

SOURCE TEXT        WHAT A READER SEES   BOGUS TAG  VERDICT
a < b              a < b                -          recovered
a <b               a                    b<         CORRUPTED
x<y                x                    y<         CORRUPTED
q <= d             q <= d               -          recovered
q<=d               q<=d                 -          recovered
<unknown>          (nothing)            unknown    CORRUPTED
x && y             x && y               -          recovered

5 recovered, 3 CORRUPTED

  table rows : 37   = 1 header + 36 data
  cells      : 252   = 36 rows x 7 columns
  raw '<' in text: 0   raw '>' in text: 0

PAGE               tidy                 xmllint              raw '<' in text
report.html        rc=1, 4 msg          rc=0, 0 err          0
broken.html        rc=1, 3 msg          rc=0, 2 err          0
rawlt_space.html   tidy rc=0, 0 msg     rc=0, 1 err          1
rawlt_letter.html  rc=1, 3 msg          rc=0, 2 err          0

and look at the last column. The corrupted page reports ZERO raw '<'
in text, because the '<b' was swallowed INTO a tag and never reached
the text at all.

test names written into the page : 9
test names a reader can see      : 9
missing from the visible text    : 0

the same check on the corrupted page: wrote 'a <b', reader sees 't a'
round trip: VALUE LOST