App-GHGen
view release on metacpan or search on metacpan
scripts/generate_index.pl view on Meta::CPAN
#!/usr/bin/env perl
# Generates the HTML for use as a testing dashboard on GitHub
# The location will be https://nigelhorne.github.io/$config{github_repo}/coverage/
# The script is automatically run by each 'git push' by the script .github/workflows/dashboard.yml
use strict;
use warnings;
use autodie qw(:all);
use File::Glob ':glob';
use File::Slurp;
use File::stat;
use IPC::Run3;
use JSON::MaybeXS;
use List::Util;
use POSIX qw(strftime);
use Readonly;
use HTTP::Tiny;
use Time::HiRes qw(sleep);
use URI::Escape qw(uri_escape);
use version;
use WWW::RT::CPAN;
my ($github_user, $github_repo);
if (my $repo = $ENV{GITHUB_REPOSITORY}) {
($github_user, $github_repo) = split m{/}, $repo, 2;
} else {
die 'What repo are you?';
}
my $package_name = $github_repo;
$package_name =~ s/\-/::/g;
Readonly my %config => (
github_user => 'nigelhorne',
github_repo => $github_repo,
package_name => $package_name,
low_threshold => 70,
med_threshold => 90,
max_points => 10, # Only display the last 10 commits in the coverage trend graph
cover_db => 'cover_db/cover.json',
output => 'cover_html/index.html',
max_retry => 3,
min_locale_samples => 3,
);
# -------------------------------
# Dependency correlation analysis
# -------------------------------
my $MAX_REPORTS_PER_GRADE = 20; # safety rail
my $ENABLE_DEP_ANALYSIS = 1;
# Read and decode coverage data
my $data = eval { decode_json(read_file($config{cover_db})) };
my $coverage_pct = 0;
my $badge_color = 'red';
if(my $total_info = $data->{summary}{Total}) {
$coverage_pct = int($total_info->{total}{percentage} // 0);
$badge_color = $coverage_pct > $config{med_threshold} ? 'brightgreen' : $coverage_pct > $config{low_threshold} ? 'yellow' : 'red';
}
Readonly my $coverage_badge_url => "https://img.shields.io/badge/coverage-${coverage_pct}%25-${badge_color}";
# Start HTML
my @html; # build in array, join later
push @html, <<"HTML";
<!DOCTYPE html>
<html>
<head>
<title>$config{package_name} Coverage Report</title>
<style>
body { font-family: sans-serif; }
table { border-collapse: collapse; width: 100%; }
th, td { border: 1px solid #ccc; padding: 8px; text-align: left; }
th { background-color: #f2f2f2; }
.low { background-color: #fdd; }
.med { background-color: #ffd; }
.high { background-color: #dfd; }
.badges img { margin-right: 10px; }
.disabled-icon {
opacity: 0.4;
cursor: default;
}
.icon-link {
text-decoration: none;
}
.icon-link:hover {
opacity: 0.7;
cursor: pointer;
}
.coverage-badge {
padding: 2px 6px;
border-radius: 4px;
font-weight: bold;
color: white;
font-size: 0.9em;
}
.badge-good { background-color: #4CAF50; }
.badge-warn { background-color: #FFC107; }
.badge-bad { background-color: #F44336; }
.summary-row {
font-weight: bold;
scripts/generate_index.pl view on Meta::CPAN
td.neutral { color: gray; }
/* Show cursor points on the headers to show that they are clickable */
th { background-color: #f2f2f2; cursor: pointer; }
th.sortable {
cursor: pointer;
user-select: none;
white-space: nowrap;
}
th .arrow {
color: #aaa; /* dimmed for inactive */
font-weight: normal;
}
th .arrow.active {
color: #000; /* dark for active */
font-weight: bold;
}
.sparkline {
display: inline-block;
vertical-align: middle;
}
tr.cpan-fail td {
background-color: #fdd;
}
tr.cpan-unknown td {
background-color: #eee;
color: #666;
}
tr.cpan-na td {
background-color: #ffffde;
color: #666;
}
.new-failure {
background: #c00;
color: #fff;
font-weight: bold;
padding: 2px 6px;
border-radius: 4px;
font-size: 0.85em;
}
.notice {
padding: 8px 12px;
margin: 10px 0;
border-radius: 4px;
font-size: 0.95em;
}
.notice strong {
font-weight: bold;
}
.notice.perl-version-cliff {
background-color: #fff3cd; /* soft amber */
border: 1px solid #ffeeba;
color: #856404;
}
.notice.perl-version-cliff a {
color: #533f03;
text-decoration: underline;
}
.notice.perl-version-cliff a:hover {
text-decoration: none;
}
.notice.locale-cliff {
border-left: 4px solid #d97706;
background: #fffbeb;
padding: 0.5em 1em;
}
.notice.rt-issues {
background: #fff6e5;
border-left: 4px solid #d9822b;
}
table.root-causes {
border-collapse: collapse;
width: 100%;
margin-bottom: 1.5em;
}
table.root-causes th,
table.root-causes td {
border: 1px solid #ccc;
padding: 8px;
vertical-align: top;
}
table.root-causes tr.high {
background-color: #dfd;
}
table.root-causes tr.med {
background-color: #ffd;
}
table.root-causes tr.low {
background-color: #fdd;
}
</style>
</head>
<body>
<div class="badges">
<a href="https://github.com/$config{github_user}/$config{github_repo}">
<img src="https://img.shields.io/github/stars/$config{github_user}/$config{github_repo}?style=social" alt="GitHub stars">
</a>
<img src="$coverage_badge_url" alt="Coverage badge">
</div>
<h1>$config{package_name}</h1><h2>Coverage Report</h2>
<table data-sort-col="0" data-sort-order="asc">
<!-- Make the column headers clickable -->
<thead>
<tr>
<th class="sortable" onclick="sortTable(this, 0)"><span class="label">File</span> <span class="arrow active">▲</span></th>
<th class="sortable" onclick="sortTable(this, 1)"><span class="label">Stmt</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 2)"><span class="label">Branch</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 3)"><span class="label">Cond</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 4)"><span class="label">Sub</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 5)"><span class="label">Total</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 6)"><span class="label">Δ</span> <span class="arrow">▲</span></th>
</tr>
</thead>
<tbody>
HTML
my @history_files = bsd_glob("coverage_history/*.json");
# Cache historical data instead of reading for each file
my %historical_cache;
for my $hist_file (@history_files) {
scripts/generate_index.pl view on Meta::CPAN
);
}
push @html, '</ul>';
}
my $perl_cliff = detect_perl_version_cliff(
\@fail_reports,
\@pass_reports,
);
if ($perl_cliff) {
my $perl_cutoff = parse_version($perl_cliff->{fails_up_to});
my $fail_support = 0;
my $pass_contra = 0;
for my $r (@fail_reports) {
next unless $r->{perl};
$fail_support++ if parse_version($r->{perl}) < $perl_cutoff;
}
for my $r (@pass_reports) {
next unless $r->{perl};
$pass_contra++ if parse_version($r->{perl}) < $perl_cutoff;
}
my ($score, $label) = confidence_score(
fail => $fail_support,
pass => $pass_contra,
);
my $confidence_html = confidence_badge_html(
$score, $label,
$fail_support, $pass_contra,
);
my $delta = perldelta_url($perl_cliff->{passes_from});
push @html,
'<p class="notice perl-version-cliff">',
sprintf(
'Fails on Perl ≤ %s; passes on Perl ≥ %s. ',
$perl_cliff->{fails_up_to},
$perl_cliff->{passes_from},
),
sprintf(
'<a href="%s" target="_blank">See perldelta for this release</a>',
$delta,
),
" $confidence_html</p>";
}
push @html, '<h3>Failure Summary</h3>';
push @html, '<ul>';
my %clusters = (
perl_series => {},
os => {},
perl_os => {},
);
my %locale_stats;
for my $r (@fail_reports) {
my $perl = perl_series($r->{perl});
my $os = $r->{osname} // 'unknown';
$clusters{perl_series}{$perl}++ if $perl;
$clusters{os}{$os}++;
$clusters{perl_os}{"$perl / $os"}++ if $perl;
if(lc($r->{grade} // '') eq 'fail') {
# Don't include NA or Unknown in this list
my $locale = extract_locale($r) // 'unknown';
$locale_stats{$locale}{fail}++;
}
}
my @top_perl_series = sort { $clusters{perl_series}{$b} <=> $clusters{perl_series}{$a} }
keys %{ $clusters{perl_series} };
my @top_os = sort { $clusters{os}{$b} <=> $clusters{os}{$a} }
keys %{ $clusters{os} };
my @top_perl_os = sort { $clusters{perl_os}{$b} <=> $clusters{perl_os}{$a} }
keys %{ $clusters{perl_os} };
if (@top_perl_series) {
my $k = $top_perl_series[0];
push @html, sprintf(
'<li><b>Perl %s.x</b>: %d failures</li>',
$k,
$clusters{perl_series}{$k},
);
my $total = scalar @fail_reports;
my $ratio_pct = ($clusters{perl_series}{$k} / $total) * 100;
if ($ratio_pct >= $config{low_threshold}) {
push @html, sprintf(
'<p><em>%d%% of failures occur on Perl %s.x</em></p>',
int($ratio_pct),
$k,
);
}
}
if (@top_os) {
my $k = $top_os[0];
push @html, sprintf(
'<li><b>%s</b>: %d failures</li>',
$k,
$clusters{os}{$k},
);
}
if (@top_perl_os) {
my $k = $top_perl_os[0];
push @html, sprintf(
'<li><b>%s</b>: %d failures</li>',
$k,
$clusters{perl_os}{$k},
);
}
push @html, '</ul>';
my @locale_clusters;
for my $r (@pass_reports) {
my $locale = extract_locale($r) // 'unknown';
$locale_stats{$locale}{pass}++;
}
for my $loc (keys %locale_stats) {
next if $loc eq 'unknown';
my $fail = $locale_stats{$loc}{fail} // 0;
my $pass = $locale_stats{$loc}{pass} // 0;
my $total = $fail + $pass;
next if $total < $config{min_locale_samples};
my $ratio = $fail / $total * 100;
if ($ratio >= $config{low_threshold} && is_non_english_locale($loc)) {
push @locale_clusters, {
locale => $loc,
fail => $fail,
pass => $pass,
ratio => $ratio,
};
}
}
if(scalar(@locale_clusters)) {
push @html,
'<h3>Locale-sensitive failures detected</h3>',
'<div class="notice locale-cliff">',
'<ul>';
foreach my $locale(@locale_clusters) {
push @html, "<li><code>$locale->{locale}</code> - $locale->{fail} FAIL / $locale->{pass} PASS ($locale->{ratio}%)</li>";
}
push @html, '</ul>', '</div>';
}
my @fail_perl_versions = extract_perl_versions(\@fail_reports);
my @pass_perl_versions = extract_perl_versions(\@pass_reports);
my @root_causes = detect_root_causes(
fail_reports => \@fail_reports,
pass_reports => \@pass_reports,
fail_perl_versions => \@fail_perl_versions,
pass_perl_versions => \@pass_perl_versions,
);
if (@root_causes) {
push @html, <<'HTML';
<h3>Likely Root Causes</h3>
<table class="root-causes">
<thead>
<tr>
<th>Cause</th>
<th>Confidence</th>
<th>Evidence</th>
</tr>
</thead>
<tbody>
HTML
for my $rc (@root_causes) {
my $confidence_pct = int($rc->{confidence} * 100);
my $confidence_class =
$confidence_pct >= $config{med_threshold} ? 'high'
: $confidence_pct >= $config{low_threshold} ? 'med'
: 'low';
my $confidence_label =
$confidence_class eq 'high' ? 'Strong'
: $confidence_class eq 'med' ? 'Moderate'
: 'Weak';
my $evidence_html = join(
'',
map { "<li>$_</li>" } @{ $rc->{evidence} || [] }
);
my $label = $rc->{label};
# Optional perldelta link
if ($rc->{type} eq 'perl' && $rc->{perldelta}) {
$label .= sprintf(
q{ (<a href="%s" target="_blank">perldelta</a>)},
$rc->{perldelta}
);
}
push @html, sprintf(<<'ROW',
<tr class="%s">
<td halign="center"><strong>%s</strong></td>
<td halign="center">%s (%d%%)</td>
<td halign="center"><ul>%s</ul></td>
scripts/generate_index.pl view on Meta::CPAN
sub perldelta_url {
my ($v) = @_;
my ($maj, $min) = $v =~ /^v?(\d+)\.(\d+)/;
return "https://perldoc.perl.org/perl${maj}${min}0delta";
}
sub confidence_score {
my (%args) = @_;
my $fail = $args{fail} // 0;
my $pass = $args{pass} // 0;
return (0, 'none') if ($fail + $pass) == 0;
my $score = $fail / ($fail + $pass);
# Convert config thresholds from percent → fraction
my $med = ($config{med_threshold} // 90) / 100;
my $low = ($config{low_threshold} // 70) / 100;
my $label =
$score >= $med ? 'strong' :
$score >= $low ? 'moderate' :
'weak';
return ($score, $label);
}
sub confidence_badge_html {
my ($score, $label, $fail, $pass) = @_;
my %class_for = (
strong => 'badge-good',
moderate => 'badge-warn',
weak => 'badge-bad',
none => 'badge-bad',
);
my $pct = sprintf('%.0f%%', $score * 100);
return sprintf(
q{<span class="coverage-badge %s" title="%d fails, %d passes">%s confidence</span>},
$class_for{$label} // 'badge-bad',
$fail, $pass,
ucfirst($label)
);
}
sub perl_series {
my $perl = $_[0];
return unless defined $perl;
# map "5.16.3" to "5.16"
if ($perl =~ /^(\d+\.\d+)/) {
return $1;
}
return;
}
sub extract_locale {
my $r = $_[0];
# Preferred: explicit environment
for my $k (qw(LANG LC_ALL LC_CTYPE)) {
if (my $v = $r->{env}{$k}) {
return $v;
}
}
# Fallback: scan report body
if (my $body = $r->{raw} || $r->{body}) {
if ($body =~ /\b([a-z]{2}_[A-Z]{2})\b/) {
return $1;
}
}
my $url = "https://api.cpantesters.org/v3/report/$r->{guid}";
my $http = HTTP::Tiny->new(agent => 'cpan-coverage-html/1.0', timeout => 15);
my $res = $http->get($url);
return unless $res->{success};
my $report = eval { decode_json($res->{content}) };
if($report->{result}->{output}->{uncategorized} =~ /\b([a-z]{2}_[A-Z]{2})\b/) {
return $1;
}
}
sub is_non_english_locale {
my $locale = $_[0];
return 0 unless $locale;
# Treat C / POSIX / en_* as English
return 0 if $locale =~ /^(C|POSIX|en(_|$))/i;
return 1;
}
sub parse_version {
my $v = $_[0];
return eval { version->parse($v) };
}
sub fetch_open_rt_ticket_count {
my $dist = $_[0];
my @rc = @{WWW::RT::CPAN::list_dist_active_tickets(dist => $dist)};
# Defensive checks
return undef unless @rc >= 3;
return undef unless $rc[0] == 200 && $rc[1] eq 'OK';
my $tickets = $rc[2] && ref $rc[2] eq 'ARRAY' ? $rc[2] : [];
return scalar @$tickets;
}
sub detect_os_root_cause {
my ($reports, $config) = @_;
my %count;
$count{ $_->{osname} // 'unknown' }++ for @$reports;
my $total = @$reports;
return unless $total >= 3;
for my $os (keys %count) {
my $ratio = $count{$os} / $total;
next unless $ratio >= ($config->{med_threshold} / 100);
return {
type => 'os',
label => "OS-specific behavior ($os)",
confidence => sprintf("%.2f", $ratio),
evidence => [
sprintf('%d/%d failures on %s', $count{$os}, $total, $os),
"Passes observed on other operating systems",
],
};
}
return;
}
sub detect_perl_version_root_cause {
my ($fail_versions, $pass_versions) = @_;
return unless @$fail_versions && @$pass_versions;
my $max_fail = List::Util::max(@$fail_versions);
my $min_pass = List::Util::min(@$pass_versions);
return unless $max_fail < $min_pass;
return {
type => 'perl',
label => "Perl version regression (Perl < $min_pass)",
confidence => 1.00,
evidence => [
"All failures on Perl ≤ $max_fail",
"All passes on Perl ≥ $min_pass",
],
perldelta => "https://perldoc.perl.org/perldelta$min_pass",
};
}
sub detect_locale_root_cause {
my ($reports, $config) = @_;
my %count;
my $total = 0;
for my $r (@$reports) {
# Can get FPs if we take NA or Unknown into account
if(lc($r->{grade} // '') eq 'fail') {
my $loc = extract_locale($r) or next;
next if $loc =~ /^en_/i;
$count{$loc}++;
$total++;
}
}
return unless $total >= 2;
for my $loc (keys %count) {
my $ratio = $count{$loc} / $total;
next unless $ratio >= ($config->{low_threshold} / 100);
return {
type => 'locale',
label => "Locale-sensitive behavior ($loc)",
confidence => sprintf("%.2f", $ratio),
evidence => [
"$count{$loc}/$total failures with LANG=$loc",
'English locales show fewer or no failures',
],
};
}
return;
}
sub detect_root_causes {
my (%args) = @_;
my @hints;
push @hints, detect_os_root_cause($args{fail_reports}, \%config) if $args{fail_reports};
push @hints, detect_locale_root_cause($args{fail_reports}, \%config);
if ($args{fail_perl_versions} && $args{pass_perl_versions}) {
push @hints,
detect_perl_version_root_cause(
$args{fail_perl_versions},
$args{pass_perl_versions},
);
}
@hints = grep { defined } @hints;
@hints = sort { $b->{confidence} <=> $a->{confidence} } @hints;
return @hints;
}
sub make_key
{
my $r = $_[0];
return lc(join '|', $r->{osname} // '', $r->{perl} // '', $r->{arch} // '', $r->{platform} // '' );
}
( run in 3.078 seconds using v1.01-cache-2.11-cpan-ceb78f64989 )