App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use warnings;
use autodie qw(:all);
use Cwd qw(abs_path);
use File::Basename qw(dirname basename);
use File::Glob ':glob';
use File::Path qw(make_path);
use File::Slurp;
use File::Spec;
use File::stat;
use Getopt::Long qw(GetOptions);
use IPC::Run3;
use JSON::MaybeXS;
use List::Util qw(max min);
use POSIX qw(strftime);
use HTML::Entities;
use HTTP::Tiny;
use Readonly;
use Storable qw(dclone);
use Time::HiRes qw(sleep);
use URI::Escape qw(uri_escape);
use version;
use WWW::RT::CPAN;
use YAML::XS qw(LoadFile);
=head1 NAME
test-generator-index - Test coverage dashboard generator
=head1 DESCRIPTION
C<test-generator-index> generates an HTML test coverage dashboard for
publication on GitHub Pages, combining four sources of test quality
data into a single report:
=over 4
=item * B<Statement and branch coverage> from L<Devel::Cover>, showing
which lines and branches were exercised by the test suite.
=item * B<LCSAJ path coverage> (TER3) from the LCSAJ runtime debugger,
showing which control-flow paths were executed. Displayed as blue
(covered) or red (uncovered) dots on per-file mutation pages.
=item * B<Mutation testing results> from C<bin/test-generator-mutate>,
showing which injected faults the test suite detected (killed) and
which it missed (survived).
=item * B<CPAN Testers failure analysis>, showing which Perl versions
and operating systems are failing, with automatic root cause detection
including Perl version cliffs, locale sensitivity, and dependency
version cliffs.
=back
In addition to the dashboard, the script drives the mutation-guided
test generation pipeline described in
L<App::Test::Generator/MUTATION-GUIDED TEST GENERATION>. Surviving
mutants are used to automatically generate new test stubs and fuzz
schemas that target the exact boundary conditions the test suite
missed:
=over 4
=item * C<--generate_mutant_tests=DIR> produces TODO stub files in
C<DIR/> for all surviving mutants, grouped by source file and
deduplicated by line.
=item * C<--generate_test=mutant> additionally attempts to produce
runnable YAML schemas in C<DIR/conf/> for NUM_BOUNDARY survivors
using L<App::Test::Generator::SchemaExtractor>.
=item * C<--generate_fuzz> augments existing schemas in C<DIR/conf/>
with boundary values from surviving mutants, writing timestamped
copies that are picked up automatically by C<t/fuzz.t>.
=back
The script is designed to be shared across projects. Copy it into the
C<scripts/> directory of each project that uses it:
bin/test-generator-index view on Meta::CPAN
# 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
</label>
<div>
</div>
</div>
<div id="zoomControls" style="margin-top:8px;">
<input type="button" value="Refresh" onClick="refresh(this)">
<button id="resetZoomBtn" type="button">Reset Zoom</button>
</div>
</div>
<canvas id="coverageTrend" width="600" height="300"></canvas>
<!-- Zoom controls for the trend chart -->
<script src="https://cdn.jsdelivr.net/npm/chart.js"></script>
<!-- Add chartjs-plugin-zoom (required for wheel/pinch/drag zoom & pan) -->
<script src="https://cdn.jsdelivr.net/npm/chartjs-plugin-zoom\@2.1.1/dist/chartjs-plugin-zoom.min.js"></script>
<script src="https://cdn.jsdelivr.net/npm/chartjs-adapter-date-fns"></script>
<script>
function linearRegression(data) {
const xs = data.map(p => new Date(p.x).getTime());
const ys = data.map(p => p.y);
const n = xs.length;
const sumX = xs.reduce((a, b) => a + b, 0);
const sumY = ys.reduce((a, b) => a + b, 0);
const sumXY = xs.reduce((acc, val, i) => acc + val * ys[i], 0);
const sumX2 = xs.reduce((acc, val) => acc + val * val, 0);
if(n < 2 || (n * sumX2 - sumX * sumX) === 0) {
return [];
}
const slope = (n * sumXY - sumX * sumY) / (n * sumX2 - sumX * sumX);
const intercept = (sumY - slope * sumX) / n;
return xs.map(x => ({
x: new Date(x).toISOString(),
y: slope * x + intercept
}));
}
HTML
my $js_data = join(",\n", @data_points);
push @html, "const dataPoints = [ $js_data ];";
push @html, <<'HTML';
const regressionPoints = linearRegression(dataPoints);
// Try to register the zoom plugin (handles different UMD builds)
(function registerZoomPlugin(){
try {
const candidates = ['chartjsPluginZoom','ChartZoom','zoomPlugin','chartjs_plugin_zoom','ChartjsPluginZoom','chartjsPluginZoom'];
bin/test-generator-index view on Meta::CPAN
responsive: false,
maintainAspectRatio: false,
elements: { line: { borderJoinStyle: 'round' } },
plugins: {
legend: { display: false },
tooltip: { enabled: false },
zoom: { // Enable zoom and pan
pan: {
enabled: true,
mode: 'x',
}, zoom: {
wheel: {
enabled: true,
},
pinch: {
enabled: true
},
mode: 'x',
}
}
}, scales: { x: { display: false }, y: { display: false } }
}
});
});
});
function refresh(){
window.location.reload("Refresh")
}
</script>
HTML
push @html, '<p><center>Use mouse wheel or pinch to zoom; drag to pan</center></p>';
} else {
push @html, '<p><i>No history to show coverage trend</i></p>';
}
# -------------------------------
# Issues flagged on RT
# -------------------------------
{
my $rt_count = fetch_open_rt_ticket_count($config{github_repo});
my $rt_url = "https://rt.cpan.org/Public/Dist/Display.html?Name=$config{github_repo}";
if(defined $rt_count && $rt_count > 0) {
push @html, '<p class="notice rt-issues">',
'<strong>RT issues:</strong>',
"<a href=\"$rt_url\" target=\"_blank\" rel=\"noopener\">",
"$rt_count open ticket" . @{[ $rt_count == 1 ? '' : 's' ]},
'</a>',
'</p>';
} else {
push @html, "<p>No issues active on <a href=\"$rt_url\">RT</a></p>";
}
}
# -------------------------------
# CPAN Testers failing reports table
# -------------------------------
my $dist_name = $config{github_repo};
my $cpan_api = "https://api.cpantesters.org/v3/summary/" . uri_escape($dist_name);
my $http = HTTP::Tiny->new(agent => 'cpan-coverage-html/1.0', timeout => 30);
my $retry = 0;
my $success = 0;
my $res;
# Try a number of times because the cpantesters website can get overloaded
while($retry < $config{max_retry}) {
$res = $http->get($cpan_api);
if($res->{success}) {
$success = 1;
last;
}
$retry++;
# Cap sleep at 16 seconds — exponential backoff but don't wait forever
my $sleep_secs = $BACKOFF_BASE_SECS ** $retry;
$sleep_secs = $BACKOFF_MAX_SECS if $sleep_secs > $BACKOFF_MAX_SECS;
sleep($sleep_secs);
}
my $version; # current version
my $prev_version; # may be undef
if($success) {
my $releases = eval { decode_json($res->{content}) };
my @versions;
foreach my $release (@{$releases}) {
next unless defined $release->{version};
push @versions, $release->{version};
}
@versions = sort { parse_version($b) <=> parse_version($a) } @versions;
$version = $versions[0]; # current
$prev_version = $versions[1]; # previous (may be undef)
} else {
push @html, "<p><a href=\"$cpan_api\">$cpan_api</a>: $res->{status} $res->{reason}</p>";
}
my @fail_reports;
my @pass_reports;
if($version) {
@fail_reports = fetch_reports_by_grades(
$dist_name,
$version,
'fail',
'unknown',
'na',
);
@pass_reports = fetch_reports_by_grades(
$dist_name,
$version,
'pass',
);
if(scalar(@fail_reports)) {
bin/test-generator-index view on Meta::CPAN
$atg_version = $1;
last;
}
}
close $fh;
}
push @html, '<footer>',
"\t<p>Project: <a href=\"https://github.com/$config{github_user}/$config{github_repo}\">$config{github_repo}</a></p>",
"\t<p><em>Last updated: $timestamp - <a href=\"$commit_url\">commit <code>$short_sha</code></a></em></p>",
"\t<p style=\"float: right; font-size: 0.85em; color: #999;\">Powered by <a href=\"https://metacpan.org/dist/App-Test-Generator\">App::Test::Generator $atg_version</a></p>",
'</footer>';
push @html, '</body>', '</html>';
# Write to index.html
print "Writing output to $config{output}\n" if($config{verbose});
write_file($config{output}, join("\n", @html));
# Generate mutant test stubs only if --generate_mutant_tests=dir was given.
# This is opt-in to avoid surprising existing pipelines with new files.
if($mutation_db && $mutant_test_dir) {
_generate_mutant_tests($mutation_db, $cover_db, $mutant_test_dir, $generate_test);
}
# Generate fuzz schema augmentations from surviving mutants
# if --generate_fuzz was passed on the command line
if($mutation_db && $generate_fuzz) {
_generate_fuzz_schemas($mutation_db, 't');
}
# --------------------------------------------------
# run_git
#
# Purpose: Execute a git command safely and return
# its stdout, or undef on failure.
#
# Entry: @cmd - list of git subcommand and args
# to pass directly to git.
#
# Exit: Returns the chomped stdout string on
# success, or undef if the command exits
# non-zero.
#
# Side effects: Forks a child process. Discards stderr.
#
# Notes: Uses IPC::Run3 to capture output without
# a shell, avoiding injection risks from
# user-supplied filenames.
# --------------------------------------------------
sub run_git {
my @cmd = @_;
my ($out, $err);
run3 ['git', @cmd], \undef, \$out, \$err;
return unless $? == 0;
chomp $out;
return $out;
}
# --------------------------------------------------
# js_escape
#
# Purpose: Escape a string for safe embedding in a
# JavaScript double-quoted string literal
# in generated HTML.
#
# Entry: $str - the string to escape.
#
# Exit: Returns the escaped string. Backslashes
# are doubled, double quotes are escaped,
# and newlines are replaced with \n.
#
# Side effects: None.
#
# Notes: Does not escape single quotes or other
# JS metacharacters — only the minimum
# needed for double-quoted string context.
# --------------------------------------------------
sub js_escape {
my $str = $_[0];
$str =~ s/\\/\\\\/g;
$str =~ s/"/\\"/g;
$str =~ s/\n/\\n/g;
return $str;
}
# --------------------------------------------------
# fetch_reports_by_grades
#
# Purpose: Fetch CPAN Testers reports for a given
# distribution and version, across one or
# more grade types (fail, pass, na, etc.),
# deduplicating across grades by make_key.
#
# Entry: $dist - distribution name
# $version - version string
# @grades - list of grade strings to fetch
# e.g. ('fail', 'unknown', 'na')
#
# Exit: Returns a list of report hashrefs,
# deduplicated across all requested grades.
# Returns an empty list if no reports found
# or all API calls fail.
#
# Side effects: Makes HTTP GET requests to the CPAN
# Testers API for each grade.
#
# Notes: Each grade is fetched separately since
# the API does not support multiple grades
# in a single request.
# --------------------------------------------------
sub fetch_reports_by_grades {
my ($dist, $version, @grades) = @_;
my %seen;
my @reports;
for my $grade (@grades) {
my $url = 'https://api.cpantesters.org/v3/summary/'
. uri_escape($dist)
. '/' . uri_escape($version)
. "?grade=$grade";
my $res = $http->get($url);
next unless $res->{success};
my $arr = eval { decode_json($res->{content}) };
next unless ref $arr eq 'ARRAY';
for my $r (@$arr) {
my $key = make_key($r);
next if $seen{$key}++;
push @reports, $r;
}
}
return @reports;
}
sub aggregate_dependency_stats {
my (%args) = @_;
my $guids = $args{guids} || [];
my $grade = $args{grade} || 'fail';
my $stats = $args{stats_ref} || {};
my $count = 0;
for my $guid (@$guids) {
last if $count++ >= $MAX_REPORTS_PER_GRADE;
my $html = fetch_report_html($guid) or next;
my $mods = extract_installed_modules($html);
for my $m (keys %$mods) {
$stats->{$m}{$grade}++;
$stats->{$m}{versions}{ $mods->{$m} }{$grade}++;
}
}
return $stats;
}
sub fetch_report_html {
my $guid = $_[0];
return unless $guid;
my $url = "https://www.cpantesters.org/cpan/report/$guid";
my $res = $http->get($url);
return unless $res->{success};
return $res->{content};
}
sub extract_installed_modules {
my ($html) = @_;
my %mods;
( run in 0.648 second using v1.01-cache-2.11-cpan-df04353d9ac )