App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
available (reproduce-GUID.sh, mode 0755).
Each script pins every installed module
version with cpanm and suggests the matching
Perl via perlbrew/plenv.
=head1 OPTIONS
--generate_mutant_tests=DIR
Generate a timestamped test stub file in DIR (typically 'xt/') 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 xt/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,
module_file => 'lib/App/Test/Generator.pm',
verbose => 1,
);
# --------------------------------------------------
# HTTP and retry constants
# --------------------------------------------------
# HTTP status code returned by HTTP::Tiny when the
bin/test-generator-index view on Meta::CPAN
# 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. Disabled automatically when
# NO_NETWORK_TESTING is set in the environment.
# --------------------------------------------------
Readonly my $ENABLE_DEP_ANALYSIS => $ENV{NO_NETWORK_TESTING} ? 0 : 1;
# Per-GUID cache of installed module hashes from fetch_report_html;
# populated by aggregate_dependency_stats, consumed by repro generation
my %module_cache;
# 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";
next if exists $cover_db->{summary}{$lib_path};
$display_file = $lib_path;
}
my $info = $cover_db->{summary}{$file};
my $html_file = $file; # Use original path (with blib/) for the link
$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
);
# 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);
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)
);
} elsif(@file_history >= 2) {
# No explicit previous-run record for this file, but it has
# sparkline history -- derive the delta from the last two points
my $delta = sprintf('%.1f', $file_history[-1] - $file_history[-2]);
my $delta_class = $delta > 0 ? 'positive' : $delta < 0 ? 'negative' : 'neutral';
my $delta_icon = $delta > 0 ? '▲' : $delta < 0 ? '▼' : '●';
$delta_html = sprintf(
'<td class="%s" title="Previous (sparkline): %.1f%%">%s %.1f%%</td>',
$delta_class, $file_history[-2], $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>';
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
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'>";
my $exec_summary;
if(!$data->{total}) {
# No mutants yet — mutation workflow not yet run
$exec_summary = "Tests execute $stmt_pct% of the code. "
. 'No mutation data available yet — trigger the mutation workflow for fault detection analysis.';
} elsif($data->{score} >= $config{med_threshold}) {
# High score — drop the 'only' and 'but'
$exec_summary = "Tests execute $stmt_pct% of the code "
. "and detect $data->{score}% of injected faults.";
} elsif($data->{score} >= $config{low_threshold}) {
# Moderate score — neutral wording
$exec_summary = "Tests execute $stmt_pct% of the code "
. "but detect only $data->{score}% of injected faults.";
} else {
# Low score — add actionable note
$exec_summary = "Tests execute $stmt_pct% of the code "
. "but detect only $data->{score}% of injected faults — "
. 'consider adding targeted tests to kill surviving mutants.';
}
push @html, $exec_summary;
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.
#
# --------------------------------------------------
sub _group_by_file {
my $data = $_[0];
my %files;
for my $status (qw(survived killed)) {
next unless $data->{$status};
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";
if(my $skipped = $mutants->{skipped}) {
print $out "<p><em>$skipped line(s) excluded by MUTANT_SKIP annotations.</em></p>\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
# --------------------------------------------------
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
# Load the LCSAJ path definitions.
# ----------------------------------------------------------
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 = $_[0];
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 FUNCTIONS
=head2 generate_reproduction_script
my $name = generate_reproduction_script($dist, $version, $report, $installed_mods, $outdir);
Generates a self-contained POSIX shell script that reproduces the exact
environment of a CPAN Testers failure report, then returns the script's
filename (C<reproduce-GUID.sh>) on success, or C<undef> if the report has
no C<guid> field.
=head3 Arguments
=over 4
=item * C<$dist> — distribution name (e.g. C<Foo-Bar>).
=item * C<$version> — distribution version string (e.g. C<1.23>).
=item * C<$report> — hashref with at minimum C<guid>, C<perl>, C<osname>,
and C<reporter> keys as returned by the CPAN Testers API.
=item * C<$installed_mods> — hashref of C<< Module => version >> pairs from
L</extract_installed_modules>, or an empty hashref.
=item * C<$outdir> — root output directory. The script is written to
C<$outdir/reproduce/reproduce-$guid.sh> (mode 0755).
=back
=head3 Output script content
The generated script contains:
=over 4
=item * A C<set -e> guard followed by a perlbrew advisory comment.
=item * If C<$installed_mods> is non-empty: a C<cpanm --notest> command that
pins every installed module at its exact failing version (modules are
single-quoted and sorted alphabetically to prevent shell-injection).
=item * A C<cpanm --look Dist@version> command to open the distribution's
source, plus a comment showing the local-checkout alternative
(C<perl Makefile.PL && make && make test>).
=back
=head2 extract_installed_modules
my $mods = extract_installed_modules($html);
Parses the C<Installed modules:> section from a CPAN Testers report HTML
page and returns a hashref of C<< Module => version >> pairs. Returns an
( run in 1.243 second using v1.01-cache-2.11-cpan-7fcb06a456a )