App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
cover_html/index.html - Main dashboard (coverage table, trend chart,
CPAN Testers failures, mutation report)
cover_html/mutation_html/ - Per-file mutation heatmap pages
=head1 OPTIONS
--generate_mutant_tests=DIR
Generate a timestamped test stub file in DIR (typically 't/') for
surviving mutants. The file is named mutant_YYYYMMDD_HHMMSS.t and
contains:
- TODO test stubs for High/Medium difficulty survivors, with
boundary value suggestions, environment variable hints, and
the enclosing subroutine name for navigation context
- Comment-only hints for Low difficulty survivors
Multiple mutations on the same source line are deduplicated into
one stub - one good test kills all variants on that line.
File is skipped entirely if there are no survivors to report.
If not given, no test stubs are generated.
--generate_test=CLASS
When combined with --generate_mutant_tests=DIR, attempts to produce
runnable test artefacts for surviving mutants rather than TODO stubs.
Currently supported classes:
mutant For NUM_BOUNDARY survivors, calls
App::Test::Generator::SchemaExtractor to extract the schema
for the enclosing subroutine and augments it with the
boundary value from the mutant (plus one value either side).
The resulting YAML schema is written to DIR/conf/ and is
picked up automatically by t/fuzz.t on the next test run.
Falls back to a TODO stub if SchemaExtractor fails, the
enclosing sub cannot be determined, or the extracted schema
confidence is too low (very_low or none).
This option is designed to accept additional classes in future, for
example corpus-driven or property-based test generation.
If not given, only TODO stubs are produced.
--generate_fuzz
Scans t/conf/ for existing YAML schema files and augments copies
of them with boundary values extracted from surviving NUM_BOUNDARY
mutants whose enclosing subroutine matches the schema's function
field. The original schema is never modified. Augmented copies are
written to t/conf/mutant_fuzz_YYYYMMDD_HHMMSS_FUNCTION.yml and
are picked up automatically by t/fuzz.t on the next test run.
Schemas whose filename already starts with mutant_fuzz_ are skipped
to avoid augmenting previously augmented schemas. Schemas with no
matching survivors are skipped (with a note if --verbose is active).
New boundary values are merged into whichever edge key already
exists in the schema (edge_case_array or edge_cases), with
deduplication against existing values.
This flag is independent of --generate_test and can be used alone.
=head1 DASHBOARD SECTIONS
Coverage Table - Per-file statement/branch/condition/subroutine
percentages with delta vs previous snapshot,
sortable columns, and sparkline trend per file
Coverage Trend - Chart of total coverage over recent commits with
linear regression line, zoom and pan support
RT Issues - Count of open RT tickets for the distribution
CPAN Testers - Failure table for the current release, with
Perl version cliff detection, locale analysis,
dependency version cliff detection, and root
cause confidence scoring
Mutation Report - Per-file mutation score (killed/survived/total),
cyclomatic complexity, and TER3 (LCSAJ path
coverage) with raw fraction
Per-file Pages - Line-by-line mutation heatmap with TER1/TER2/TER3
metrics, LCSAJ path markers, and expandable
mutant details with suggested tests
=head1 DEPENDENCIES
Cwd, File::Basename, File::Glob, File::Path,
File::Slurp, File::Spec, File::stat, Getopt::Long, HTML::Entities,
HTTP::Tiny, IPC::Run3, JSON::MaybeXS, List::Util, POSIX,
Readonly, Time::HiRes, URI::Escape, WWW::RT::CPAN, version
=cut
my ($github_user, $github_repo);
if(my $repo = $ENV{GITHUB_REPOSITORY}) {
($github_user, $github_repo) = split m{/}, $repo, 2;
} else {
die 'GITHUB_REPOSITORY environment variable is not set';
}
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_html/cover.json', # Devel::Cover JSON output
mutation_db => 'mutation.json',
mutation_dir => 'coverage/mutation_html', # hrefs in published pages
mutation_output_dir => 'cover_html/mutation_html', # where files are written
lcsaj_root => 'cover_html/mutation_html/lib',
lcsaj_hits_file => 'cover_html/lcsaj_hits.json', # Runtime.pm writes here
output => 'cover_html/index.html', # published to gh-pages
max_retry => 5,
min_locale_samples => 3,
verbose => 1,
);
# --------------------------------------------------
# HTTP and retry constants
# --------------------------------------------------
# HTTP status code returned by HTTP::Tiny when the
# connection itself fails (as opposed to a server error)
bin/test-generator-index view on Meta::CPAN
# a 'universal failure' diagnosis is ruled out —
# if more than this fraction pass, the release is not
# universally broken
Readonly my $UNIVERSAL_FAILURE_PASS_THRESHOLD => 0.10;
# Confidence score assigned to the 'scattered failures'
# root cause — intentionally low since it is a weak
# signal with no clear version or OS pattern
Readonly my $SCATTERED_FAILURES_CONFIDENCE => 0.40;
# --------------------------------------------------
# Test stub generation constants
# --------------------------------------------------
# Width of the separator lines printed between file
# sections in the generated mutant test stub file
Readonly my $STUB_SEPARATOR_WIDTH => 64;
# --------------------------------------------------
# Parse command-line options.
# --generate_mutant_tests=dir enables test stub
# generation into the named directory.
# --generate_test=CLASS enables schema generation
# for surviving mutants.
# --generate_fuzz enables fuzz schema augmentation
# from surviving mutants.
# --------------------------------------------------
my $mutant_test_dir;
my $generate_test;
my $generate_fuzz;
GetOptions(
'generate_mutant_tests=s' => \$mutant_test_dir,
'generate_test=s' => \$generate_test,
'generate_fuzz' => \$generate_fuzz,
) or die "Usage: $0 [--generate_mutant_tests=DIR] [--generate_test=mutant] [--generate_fuzz]";
# -------------------------------
# Dependency correlation analysis
# -------------------------------
# --------------------------------------------------
# Maximum number of CPAN Testers reports to fetch
# per grade when performing dependency correlation
# analysis — acts as a safety rail against runaway
# API requests on distributions with many failures
# --------------------------------------------------
Readonly my $MAX_REPORTS_PER_GRADE => 20;
# --------------------------------------------------
# Enable dependency correlation analysis against
# CPAN Testers reports. Set to 0 to disable if the
# API is unreachable or the analysis is too slow.
# --------------------------------------------------
Readonly my $ENABLE_DEP_ANALYSIS => 1;
# Read and decode data
my $cover_db = eval { decode_json(read_file($config{cover_db})) };
my $mutation_db = eval { decode_json(read_file($config{mutation_db})) };
# --------------------------------------------------
# Compute coverage percentage from only our own files,
# excluding absolute paths (installed CPAN modules)
# which inflate Devel::Cover's pre-aggregated Total.
# --------------------------------------------------
my ($coverage_pct, $badge_color) = (0, 'red');
if($cover_db->{summary}) {
my ($sum, $count) = (0, 0);
for my $f (keys %{ $cover_db->{summary} }) {
next if $f eq 'Total';
next if $f =~ /^\//; # skip absolute paths
$sum += $cover_db->{summary}{$f}{total}{percentage} // 0;
$count++;
}
if($count) {
my $pct = _own_file_coverage_pct($cover_db->{summary});
$coverage_pct = defined $pct ? int($pct) : 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;
background-color: #f0f0f0;
}
td.positive { color: green; font-weight: bold; }
td.negative { color: red; font-weight: bold; }
td.neutral { color: gray; }
/* Show cursor points on the headers to show that they are clickable */
th { background-color: #f2f2f2; cursor: pointer; }
bin/test-generator-index view on Meta::CPAN
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) {
my $json = eval { decode_json(read_file($hist_file)) };
$historical_cache{$hist_file} = $json if $json;
}
# Load previous snapshot for delta comparison
my @history = sort { $a cmp $b } @history_files;
my $prev_data;
if(@history >= 1) {
my $prev_file = $history[-1]; # Most recent before current
$prev_data = $historical_cache{$prev_file};
}
my %deltas;
if($prev_data) {
for my $file (keys %{$cover_db->{summary}}) {
next if $file eq 'Total';
next if $file =~ /^\//; # skip absolute paths
# Normalise blib/ paths and deduplicate against lib/ entries
my $delta_key = $file;
if($file =~ /^blib\/lib\/(.+)$/) {
next if exists $cover_db->{summary}{"lib/$1"};
$delta_key = "lib/$1";
}
my $curr = $cover_db->{summary}{$file}{total}{percentage} // 0;
my $prev = $prev_data->{summary}{$file}{total}{percentage}
// $prev_data->{summary}{$delta_key}{total}{percentage}
// 0;
my $delta = sprintf('%.1f', $curr - $prev);
$deltas{$delta_key} = $delta;
}
}
# Check if we're in a git repository first
unless(run_git('rev-parse', '--git-dir')) {
die 'Error: Not in a git repository or git is not available';
}
my $commit_sha = run_git('rev-parse', 'HEAD');
unless(defined $commit_sha && $commit_sha =~ /^[0-9a-f]{40}$/i) {
die 'Error: Could not get valid git commit SHA';
}
my $github_base = "https://github.com/$config{github_user}/$config{github_repo}/blob/$commit_sha/";
# Add rows
my ($total_files, $total_coverage, $low_coverage_count) = (0, 0, 0);
for my $file (sort keys %{$cover_db->{summary}}) {
next if $file eq 'Total';
next if $file =~ /^\//; # skip absolute paths (installed modules)
# Normalise blib/lib/ paths to lib/ for display.
# Devel::Cover instruments blib/ during testing but we
# want to show lib/ paths to match the source tree.
my $display_file = $file;
if($file =~ /^blib\/lib\/(.+)$/) {
my $lib_path = "lib/$1";
# If a native lib/ version exists, skip this blib/ entry
# to avoid duplicate rows
next if exists $cover_db->{summary}{$lib_path};
$display_file = $lib_path;
}
my $info = $cover_db->{summary}{$file};
my $html_file = $display_file;
$html_file =~ s|/|-|g;
$html_file =~ s|\.pm$|-pm|;
$html_file =~ s|\.pl$|-pl|;
$html_file .= '.html';
my $total = $info->{total}{percentage} // 0;
$total_files++;
$total_coverage += $total;
$low_coverage_count++ if $total < $config{low_threshold};
my $badge_class = $total >= $config{med_threshold} ? 'badge-good'
: $total >= $config{low_threshold} ? 'badge-warn'
: 'badge-bad';
my $tooltip = $total >= $config{med_threshold} ? 'Excellent coverage'
: $total >= $config{low_threshold} ? 'Moderate coverage'
: 'Needs improvement';
my $row_class = $total >= $config{med_threshold} ? 'high'
: $total >= $config{low_threshold} ? 'med'
: 'low';
my $badge_html = sprintf(
'<span class="coverage-badge %s" title="%s">%.1f%%</span>',
$badge_class, $tooltip, $total
);
my $delta_html;
if(exists $deltas{$file}) {
my $delta = $deltas{$file};
my $delta_class = $delta > 0 ? 'positive' : $delta < 0 ? 'negative' : 'neutral';
my $delta_icon = $delta > 0 ? '▲' : $delta < 0 ? '▼' : '●';
my $prev_pct = $prev_data->{summary}{$file}{total}{percentage} // 0;
$delta_html = sprintf(
'<td class="%s" title="Previous: %.1f%%">%s %.1f%%</td>',
$delta_class, $prev_pct, $delta_icon, abs($delta)
);
} else {
$delta_html = '<td class="neutral" title="No previous data">●</td>';
}
my $source_url = $github_base . $display_file;
my $has_coverage = (
defined $info->{statement}{percentage} ||
defined $info->{branch}{percentage} ||
defined $info->{condition}{percentage} ||
defined $info->{subroutine}{percentage}
);
my $source_link = $has_coverage
? sprintf('<a href="%s" class="icon-link" title="View source on GitHub">🔍</a>', $source_url)
: '<span class="disabled-icon" title="No coverage data">🔍</span>';
# Create the sparkline - limit to last N points like the main trend chart
my @file_history;
# Get the last max_points history files (same as trend chart)
my @limited_history = (scalar(@history_files) > $config{max_points})
? @history_files[-$config{max_points} .. -1]
: @history_files;
# Use the already-cached historical data
for my $hist_file (sort @limited_history) {
my $json = $historical_cache{$hist_file};
next unless $json; # Skip if not cached (shouldn't happen, but be safe)
# Try both with and without blib/ prefix since older history
# files store paths under blib/lib/... while the dashboard
# displays them as lib/...
my $hist_key = $json->{summary}{"blib/$file"} ? "blib/$file"
: $json->{summary}{$file} ? $file
: undef;
if($hist_key) {
my $pct = $json->{summary}{$hist_key}{total}{percentage} // 0;
push @file_history, sprintf('%.1f', $pct);
}
}
my $points_attr = join(',', @file_history);
push @html, sprintf(
qq{<tr class="%s"><td><a href="%s" title="View coverage line by line" target="_blank">%s</a> %s<canvas class="sparkline" width="80" height="20" data-points="$points_attr"></canvas></td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%s</td>...
$row_class, $html_file, $display_file, $source_link,
$info->{statement}{percentage} // 0,
$info->{branch}{percentage} // 0,
$info->{condition}{percentage} // 0,
$info->{subroutine}{percentage} // 0,
$badge_html,
$delta_html
);
}
# Summary row
my $avg_coverage = $total_files ? int($total_coverage / $total_files) : 0;
push @html, sprintf(
qq{<tr class="summary-row nosort"><td colspan="2"><strong>Summary</strong></td><td colspan="2">%d files</td><td colspan="3">Avg: %d%%, Low: %d</td></tr>},
$total_files, $avg_coverage, $low_coverage_count
);
# Add totals row
# Compute totals only across the files we actually displayed,
# ignoring Devel::Cover's pre-aggregated Total which includes
# all instrumented files (CPAN modules etc.) not just our own
my ($sum_stmt, $sum_branch, $sum_cond, $sum_sub, $sum_total) = (0, 0, 0, 0, 0);
my $counted = 0;
for my $file (keys %{$cover_db->{summary}}) {
next if $file eq 'Total';
next if $file =~ /^\//; # skip absolute paths (installed modules)
# Skip blib/ entries that have a corresponding lib/ entry
# to avoid counting the same file twice in the totals
if($file =~ /^blib\/lib\/(.+)$/) {
next if exists $cover_db->{summary}{"lib/$1"};
}
my $info = $cover_db->{summary}{$file};
$sum_stmt += $info->{statement}{percentage} // 0;
$sum_branch += $info->{branch}{percentage} // 0;
$sum_cond += $info->{condition}{percentage} // 0;
$sum_sub += $info->{subroutine}{percentage} // 0;
$sum_total += $info->{total}{percentage} // 0;
$counted++;
}
if($counted) {
my $avg_total = $sum_total / $counted;
my $class = $avg_total > 80 ? 'high' : $avg_total > 50 ? 'med' : 'low';
push @html, sprintf(
qq{<tr class="%s nosort"><td><strong>Total</strong></td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td>%.1f</td><td colspan="2"><strong>%.1f</strong></td></tr>},
$class,
$sum_stmt / $counted,
$sum_branch / $counted,
$sum_cond / $counted,
$sum_sub / $counted,
$avg_total
);
}
Readonly my $commit_url => "https://github.com/$config{github_user}/$config{github_repo}/commit/$commit_sha";
my $short_sha = substr($commit_sha, 0, 7);
push @html, '</tbody></table>';
# Inject chart if we have data
# Use full 40-character SHAs as keys throughout to avoid the
# ambiguity of Git's variable-length short SHA abbreviations,
# which grow beyond 7 characters as the repository expands
my %commit_times;
my $log_output = run_git('log', '--all', '--pretty=format:%H %ci');
if($log_output) {
for my $line (split /\n/, $log_output) {
# Full SHA and datetime are space-separated; limit split
# to 2 fields so datetime with spaces is preserved intact
my ($full_sha, $datetime) = split ' ', $line, 2;
$commit_times{$full_sha} = $datetime if $full_sha;
}
}
my %commit_messages;
$log_output = run_git('log', '--pretty=format:%H %s');
if($log_output) {
for my $line (split /\n/, $log_output) {
# Extract full 40-char SHA and commit subject line
my ($full_sha, $message) = $line =~ /^([0-9a-f]{40})\s+(.*)$/;
# Skip merge commits — they add noise to the trend chart
if($message && $message =~ /^Merge branch /) {
delete $commit_times{$full_sha};
} else {
$commit_messages{$full_sha} = $message if $message;
}
}
}
# Build short-to-full SHA mapping so filename SHAs of any
# length can be resolved to their full commit SHA.
# We use //= so that if two commits share a prefix (unlikely
# but possible), the first one wins rather than silently
# overwriting with a later one
my %sha_lookup;
for my $full (keys %commit_messages) {
# Index every prefix from 7 chars up to the full SHA length
# so that history filenames with any abbreviation length match
for my $len (7 .. length($full)) {
my $prefix = substr($full, 0, $len);
$sha_lookup{$prefix} //= $full;
}
}
# Collect data points from non-merge commits
my @data_points_with_time;
my $processed_count = 0;
foreach my $file (reverse sort @history_files) {
last if $processed_count >= $config{max_points};
my $json = $historical_cache{$file};
next unless $json->{summary};
# Extract the commit SHA from the history filename.
# SHA length varies (7+ chars) as Git increases abbreviation
# length automatically when the repository grows — so we match
# any run of hex characters rather than a fixed 7-character width
my ($sha) = $file =~ /-([0-9a-f]+)\.json$/i;
# Skip files that don't match the expected naming pattern
# e.g. YYYY-MM-DD-SHA.json — $sha will be undef otherwise
next unless defined $sha;
# Resolve the short filename SHA to a full SHA first,
# then check the full SHA in %commit_messages
my $full_sha = $sha_lookup{$sha};
next unless defined $full_sha;
next unless $commit_messages{$full_sha}; # skip merge commits
# Compute average across our own files only
my ($sum, $count) = (0, 0);
for my $f (keys %{ $json->{summary} }) {
next if $f eq 'Total';
next if $f =~ /^\//;
next unless $f =~ /^(?:lib|blib|bin)\//; # only own project files
$sum += $json->{summary}{$f}{total}{percentage} // 0;
$count++;
}
next unless $count;
# Use full SHA for lookups and URL
my $timestamp = $commit_times{$full_sha} // strftime('%Y-%m-%dT%H:%M:%S', localtime((stat($file))->mtime));
# Git log returns format like: "2024-01-15 14:30:45 -0500" or "2024-01-15 14:30:45 +0000"
# We need ISO 8601 format: "2024-01-15T14:30:45-05:00"
# Replace space between date and time with 'T'
$timestamp =~ s/^(\d{4}-\d{2}-\d{2}) (\d{2}:\d{2}:\d{2})/$1T$2/;
# Fix timezone format: convert "-0500" to "-05:00" or " -05:00" to "-05:00"
$timestamp =~ s/\s*([+-])(\d{2}):?(\d{2})$/$1$2:$3/;
# Remove any remaining spaces (safety cleanup)
$timestamp =~ s/\s+//g;
my $pct = $sum / $count;
my $color = 'gray'; # Will be set properly after sorting
my $url = "https://github.com/$config{github_user}/$config{github_repo}/commit/$full_sha";
my $comment = $commit_messages{$full_sha};
# Store with timestamp for sorting
push @data_points_with_time, {
timestamp => $timestamp,
pct => $pct,
url => $url,
comment => $comment
};
$processed_count++;
}
# Sort by timestamp to ensure chronological order
@data_points_with_time = sort { $a->{timestamp} cmp $b->{timestamp} } @data_points_with_time;
# Now calculate deltas and create JavaScript data points
my @data_points;
my $prev_pct;
foreach my $point (@data_points_with_time) {
my $delta = defined $prev_pct ? sprintf('%.1f', $point->{pct} - $prev_pct) : 0;
$prev_pct = $point->{pct};
my $color = $delta > 0 ? 'green' : $delta < 0 ? 'red' : 'gray';
my $comment = js_escape($point->{comment});
push @data_points, qq{{ x: "$point->{timestamp}", y: $point->{pct}, delta: $delta, url: "$point->{url}", label: "$point->{timestamp}", pointBackgroundColor: "$color", comment: "$comment" }};
}
if(scalar(@data_points)) {
push @html, <<'HTML';
<div style="display: flex; justify-content: space-between; align-items: center; margin-bottom: 1em;">
<div>
<h2>Coverage Trend</h2>
<label>
<input type="checkbox" id="toggleTrend" checked>
Show regression trend
bin/test-generator-index view on Meta::CPAN
if(parse_version($fail_median) > parse_version($pass_median)) {
push @suspects, {
module => $mod,
type => 'soft',
message => sprintf(
'FAIL median %s > PASS median %s',
$fail_median,
$pass_median,
),
};
}
}
return @suspects;
}
sub detect_perl_version_cliff {
my ($fail_reports, $pass_reports) = @_;
my @fail_perls = extract_perl_versions($fail_reports);
my @pass_perls = extract_perl_versions($pass_reports);
return unless @fail_perls && @pass_perls;
my $max_fail = (sort { $b <=> $a } @fail_perls)[0];
my $min_pass = (sort { $a <=> $b } @pass_perls)[0];
return unless $min_pass > $max_fail;
return { fails_up_to => $max_fail, passes_from => $min_pass };
}
sub extract_perl_versions {
my ($reports) = @_;
my @v;
for my $r (@$reports) {
next unless $r->{perl};
push @v, parse_version($r->{perl});
}
return @v;
}
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}";
bin/test-generator-index view on Meta::CPAN
qq{<tr class="%s"><td><a href="%s" title="View mutation line by line" target="_blank">%s</a> %s</td><td>%d</td><td>%d</td><td>%d</td><td>%s</td><td>%s</td><td>%s</td></tr>},
$row_class,
$html_file,
$file,
$source_link,
$total,
$killed,
$survived,
$badge_html,
$complexity_html,
$ter_cell,
);
}
push @html, "</table>\n";
# --------------------------------------------------
# Structural Coverage Summary (if provided)
# --------------------------------------------------
if($coverage_data) {
my ($stmt_total, $stmt_hit, $branch_total, $branch_hit) = _coverage_totals($coverage_data);
my $stmt_pct = $stmt_total ? sprintf('%.2f', ($stmt_hit / $stmt_total) * 100) : 0;
my $branch_pct = $branch_total ? sprintf('%.2f', ($branch_hit / $branch_total) * 100) : 0;
push @html, "<h2>Structural Coverage (Approximate)</h2>";
push @html, "<div class='summary'>";
push @html, "Statement Coverage: $stmt_pct% ($stmt_hit / $stmt_total)<br>";
push @html, "Branch Coverage: $branch_pct% ($branch_hit / $branch_total)<br>";
push @html, '<em>Approximate LCSAJ derived from branch and statement coverage.</em>';
push @html, '</div>';
# --------------------------------------------------
# Executive summary
# Statement coverage shows how much code runs.
# Mutation score shows how well tests detect faults.
# --------------------------------------------------
push @html, '<h2>Executive Summary</h2>';
push @html, "<div class='summary'>";
push @html, "Tests execute $stmt_pct% of the code, but detect only $data->{score}% of injected faults.";
push @html, '</div>';
}
return \@html;
}
sub _file_score {
my $file_data = $_[0];
my $killed = scalar @{ $file_data->{killed} || [] };
my $survived = scalar @{ $file_data->{survived} || [] };
my $total = $killed + $survived;
return $total ? ($killed / $total) * 100 : 0;
}
# --------------------------------------------------
# _ter_badge
#
# Purpose: Format a single TER percentage value as
# a colour-coded HTML badge, consistent
# with the coverage badge style used
# elsewhere in the dashboard.
#
# Entry: $pct - percentage value (0-100), or
# undef if data is unavailable
# $label - fallback text to display when
# $pct is undef (e.g. 'n/a')
#
# Exit: Returns an HTML span string. Never
# returns undef.
#
# Side effects: None.
#
# Notes: Thresholds are taken from %config:
# >= med_threshold -> green (badge-good)
# >= low_threshold -> yellow (badge-warn)
# < low_threshold -> red (badge-bad)
# Undef input produces a grey badge with
# title="No data".
# --------------------------------------------------
sub _ter_badge {
my ($pct, $label) = @_;
unless(defined $pct) {
return qq{<span class="coverage-badge" style="background-color:#999" title="No data">$label</span>};
}
my ($class, $tooltip) =
$pct >= $config{med_threshold} ? ('badge-good', 'Excellent') :
$pct >= $config{low_threshold} ? ('badge-warn', 'Moderate') :
('badge-bad', 'Needs improvement');
return sprintf(
'<span class="coverage-badge %s" title="%s">%.1f%%</span>',
$class, $tooltip, $pct
);
}
# --------------------------------------------------
# _group_by_file
#
# Purpose: Partition a flat list of mutant hashrefs
# (from the mutation JSON) into a nested
# hashref keyed by source file, then by
# status (survived/killed).
#
# Entry: $data - decoded mutation JSON hashref
# containing 'survived' and 'killed'
# arrayrefs.
#
# Exit: Returns a hashref of the form:
# { filename => { survived => [...],
# killed => [...] } }
# Mutants missing a 'file' field are
# silently skipped.
#
# Side effects: None.
# --------------------------------------------------
sub _group_by_file {
my $data = $_[0];
my %files;
for my $status (qw(survived killed)) {
bin/test-generator-index view on Meta::CPAN
open my $out, '>', $relative_path or die "$relative_path: $!";
print $out _mutant_file_header("File: $file");
print $out "<h1>$file</h1>\n";
# Navigation bar
print $out qq{<div class="nav">};
if($prev) {
my $link = _relative_link($file, $prev);
print $out qq{<a href="$link">⬅ Previous</a> };
}
# Calculate depth of $file within lib/ to build correct relative path back to index.html
# $file is something like lib/CGI/Info.pm or lib/App/Test/Generator.pm
(my $rel = $file) =~ s{^lib/}{};
my @parts = File::Spec->splitdir($rel);
my $depth = scalar(@parts) - 1; # subdirs only, exclude filename
my $ups = '../' x ($depth + 2); # +2 for lib/ and mutation_html/
my $index_link = "${ups}index.html";
print $out qq{<a href="$index_link">Index</a>\n};
if($next) {
my $link = _relative_link($file, $next);
print $out qq{ <a href="$link">Next âž¡</a>};
}
print $out qq{</div>};
# --------------------------------------------------
# File-level structural coverage (if available)
# --------------------------------------------------
if($coverage_data) {
if(my $file_cov = _coverage_for_file($coverage_data, $file)) {
my $stmt_total = $file_cov->{statement}{total} || 0;
my $stmt_hit = $file_cov->{statement}{covered} || 0;
my $branch_total = $file_cov->{branch}{total} || 0;
my $branch_hit = $file_cov->{branch}{covered} || 0;
my $stmt_pct = $stmt_total ? sprintf('%.2f', ($stmt_hit / $stmt_total) * 100) : 0;
my $branch_pct = $branch_total ? sprintf('%.2f', ($branch_hit / $branch_total) * 100) : 0;
my $approx_lcsaj = $branch_total + 1;
# Compute TER3 (LCSAJ path coverage) for this file if data is available.
# TER3 = covered_paths / total_paths * 100
my ($lcsaj_cov, $lcsaj_total) = _lcsaj_coverage_for_file(
$file, $lcsaj_dir, $lcsaj_hits, []
);
my $ter3_str;
if(!defined $lcsaj_cov) {
# .lcsaj.json not found — TER3 unavailable for this file
$ter3_str = 'n/a';
} elsif(!$lcsaj_total) {
# File found but no paths defined
$ter3_str = '-';
} else {
# Format as percentage with raw fraction for clarity
$ter3_str = sprintf('%.1f%% (%d/%d)',
($lcsaj_cov / $lcsaj_total) * 100,
$lcsaj_cov,
$lcsaj_total
);
}
# Display TER1/TER2/TER3 coverage metrics in the summary block.
# TER1 = statement, TER2 = branch, TER3 = LCSAJ path coverage.
print $out "<div class='summary'>\n";
print $out "<strong>Structural Coverage (Approximate)</strong><p>\n";
print $out "TER1 (Statement): $stmt_pct%<br>\n";
print $out "TER2 (Branch): $branch_pct%<br>\n";
print $out "TER3 (LCSAJ): $ter3_str<br>\n";
print $out "Approximate LCSAJ segments: $approx_lcsaj<br>\n";
print $out "</div>\n";
print $out qq{
<div class="legend">
<h3>LCSAJ Legend</h3>
<p>
<span class="lcsaj-dot">â—</span>
<b>Covered</b> — this LCSAJ path was executed during testing.
</p>
<p>
<span class="lcsaj-dot-uncovered">â—</span>
<b>Not covered</b> — this LCSAJ path was never executed. These are the paths to focus on.
</p>
<p>
Multiple dots on a line indicate that multiple control-flow paths begin at that line.
Hovering over any dot shows:
</p>
<pre>
start → end → jump
</pre>
<ul>
<li><b>start</b> – first line of the linear sequence</li>
<li><b>end</b> – last line before control flow changes</li>
<li><b>jump</b> – line execution jumps to next</li>
</ul>
<p>
Uncovered paths show <b>[NOT COVERED]</b> in the tooltip.
</p>
</div>
};
}
}
# --------------------------------------------------
# Legend explaining line colours
# --------------------------------------------------
print $out qq{
<div class="legend">
<h3>Mutant Testing Legend</h3>
bin/test-generator-index view on Meta::CPAN
};
}
sub _mutant_file_footer {
return qq{
<script>
function toggleTheme() {
const html = document.documentElement;
const current = html.getAttribute('data-theme');
const next = current === 'dark' ? 'light' : 'dark';
html.setAttribute('data-theme', next);
localStorage.setItem('theme', next);
}
(function() {
const saved = localStorage.getItem('theme');
if(saved) {
document.documentElement.setAttribute('data-theme', saved);
}
})();
document.addEventListener("mousemove", function(e) {
document.querySelectorAll(".lcsaj-tip-text").forEach(function(tip) {
tip.style.left = (e.clientX + 12) + "px";
tip.style.top = (e.clientY + 12) + "px";
});
});
</script>
</body>
</html>
};
}
# --------------------------------------------------
# _coverage_totals
#
# Purpose: Extract aggregate structural coverage
# totals from a Devel::Cover JSON report,
# computed only across the project's own
# source files. Used to populate the
# Structural Coverage and Executive
# Summary sections of the dashboard.
#
# Entry: $cov - decoded Devel::Cover JSON
# hashref as returned by
# decode_json(read_file(...)).
# May be undef.
#
# Exit: Returns a four-element list:
# ($stmt_total, $stmt_hit,
# $branch_total, $branch_hit)
# Returns (0, 0, 0, 0) if $cov is undef,
# not a hashref, or contains no summary.
#
# Side effects: None.
#
# Notes: Devel::Cover's pre-aggregated 'Total'
# key includes all instrumented files —
# CPAN dependencies, blib/ copies, and
# absolute paths — which inflates the
# reported percentage. This function
# recomputes from per-file entries,
# applying the same own-file filter
# (lib/, blib/, bin/ prefixes only, no
# absolute paths) used in the coverage
# table and badge calculation.
# blib/ entries that have a corresponding
# lib/ entry are skipped to avoid
# double-counting.
# --------------------------------------------------
sub _coverage_totals
{
my $cov = $_[0];
# Defensive checks to avoid warnings
return (0,0,0,0) unless $cov;
return (0,0,0,0) unless ref $cov eq 'HASH';
return (0,0,0,0) unless $cov->{summary};
my ($stmt_total, $stmt_hit, $branch_total, $branch_hit) = (0, 0, 0, 0);
for my $file (keys %{ $cov->{summary} }) {
# Skip the pre-aggregated Total — it includes CPAN modules
next if $file eq 'Total';
# Skip absolute paths (installed CPAN modules)
next if $file =~ /^\//;
# Skip blib/ entries that have a corresponding lib/ entry
# to avoid double-counting the same file
if($file =~ /^blib\/lib\/(.+)$/) {
next if exists $cov->{summary}{"lib/$1"};
}
# Only count own project files
next unless $file =~ /^(?:lib|blib|bin)\//;
my $info = $cov->{summary}{$file};
# Accumulate raw totals and hits across own files
$stmt_total += $info->{statement}{total} || 0;
$stmt_hit += $info->{statement}{covered} || 0;
$branch_total += $info->{branch}{total} || 0;
$branch_hit += $info->{branch}{covered} || 0;
}
return ($stmt_total, $stmt_hit, $branch_total, $branch_hit);
}
# --------------------------------------------------
# _coverage_for_file
#
# Purpose: Look up Devel::Cover coverage data for
# a single source file, trying multiple
# path forms to cope with the variety of
# ways Devel::Cover records file paths
# across different project layouts and
# Perl versions.
#
# Entry: $cov - decoded Devel::Cover JSON
# hashref. May be undef.
bin/test-generator-index view on Meta::CPAN
# ----------------------------------------------------------
open my $fh, '<', $lcsaj_file
or do {
return (undef, undef);
};
my $paths = decode_json(do { local $/; <$fh> });
close $fh;
my $total = scalar @{ $paths // [] };
return (0, 0) unless $total;
# ----------------------------------------------------------
# Resolve which hit-map entry belongs to this file.
# Runtime.pm writes keys as _normalize(abs_path(file)), which
# produces "lib/Foo/Bar.pm". Try several key forms so we match
# regardless of what the caller passed in.
# ----------------------------------------------------------
my $norm_abs = $abs;
$norm_abs =~ s{^.*/blib/lib/}{lib/};
$norm_abs =~ s{^.*/lib/}{lib/};
my $norm_orig = $original;
$norm_orig =~ s{^.*/blib/lib/}{lib/};
$norm_orig =~ s{^.*/lib/}{lib/};
my $file_hits =
$hits->{$norm_abs} # "lib/Foo/Bar.pm" (most likely)
// $hits->{$norm_orig} # same, from original arg
// $hits->{$abs} # absolute path (unusual)
// $hits->{$original} # raw arg as-is
// {};
# ----------------------------------------------------------
# Count how many LCSAJ paths had at least one line executed.
# A path is considered covered if any line in [start..end]
# appears in the hit map.
# ----------------------------------------------------------
my $covered = 0;
for my $p (@{ $paths }) {
next unless ref $p eq 'HASH';
my $start = $p->{start};
my $end = $p->{end};
next unless defined $start && defined $end;
for my $line ($start .. $end) {
if($file_hits->{$line}) {
$covered++;
last;
}
}
}
return ($covered, $total);
}
# --------------------------------------------------
# _own_file_coverage_pct
#
# Compute average coverage percentage across only the
# project's own files in a Devel::Cover summary hashref,
# excluding Devel::Cover's pre-aggregated Total key and
# any absolute paths (installed CPAN modules) which
# would otherwise inflate the reported figure.
#
# Arguments:
# $summary - hashref of Devel::Cover summary data
#
# Returns:
# Average total coverage percentage, or undef if no
# qualifying files found
# --------------------------------------------------
sub _own_file_coverage_pct {
my ($summary) = @_;
return undef unless $summary;
my ($sum, $count) = (0, 0);
for my $f (keys %$summary) {
next if $f eq 'Total';
next if $f =~ /^\//; # skip absolute paths
next unless $f =~ /^(?:lib|blib|bin)\//; # only own project files
$sum += $summary->{$f}{total}{percentage} // 0;
$count++;
}
return $count ? $sum / $count : undef;
}
=head1 AUTHOR
Nigel Horne <njh@nigelhorne.com>
=cut
( run in 1.825 second using v1.01-cache-2.11-cpan-39bf76dae61 )