App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
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++;
}
# Append the current run as the final trend point if it is not already
# present in the archive. The snapshot is written AFTER the HTML is
# generated, so the current commit's entry will normally be absent —
# the last visible trend point would otherwise be the previous commit's,
# which may have anomalously low coverage (e.g. a partial Devel::Cover
# run) and makes the trend appear to crash just before the current date.
unless(grep { index($_->{url}, $commit_sha) >= 0 } @data_points_with_time) {
my ($cur_sum, $cur_count) = (0, 0);
for my $f (keys %{$cover_db->{summary}}) {
next if $f eq 'Total';
next if $f =~ /^\//;
next unless $f =~ /^(?:lib|blib|bin)\//;
$cur_sum += $cover_db->{summary}{$f}{total}{percentage} // 0;
$cur_count++;
}
if($cur_count) {
my $cur_ts = strftime('%Y-%m-%dT%H:%M:%S', localtime);
my $tz = strftime('%z', localtime);
$tz =~ s/([+-])(\d{2})(\d{2})/$1$2:$3/;
$cur_ts .= $tz;
push @data_points_with_time, {
timestamp => $cur_ts,
pct => $cur_sum / $cur_count,
url => "https://github.com/$config{github_user}/$config{github_repo}/commit/$commit_sha",
comment => $commit_messages{$commit_sha} // 'Current run',
};
}
}
# Sort by timestamp to ensure chronological order
@data_points_with_time = sort { $a->{timestamp} cmp $b->{timestamp} } @data_points_with_time;
bin/test-generator-index view on Meta::CPAN
my $version_str = $version // 'unknown';
push @html, "<p>No CPAN Testers failures reported for $dist_name $version_str.</p>";
} else {
my $reason = $res->{status} == $HTTP_CONNECTION_FAILED
? 'CPAN Testers API temporarily unreachable'
: "$res->{status} $res->{reason}";
push @html, "<p><em>CPAN Testers data unavailable: $reason. "
. "Check <a href=\"$cpan_api\">$cpan_api</a> manually.</em></p>";
}
# Output the Mutation Overview
if($mutation_db) {
my $lcsaj_hits;
if($config{lcsaj_hits_file} && -f $config{lcsaj_hits_file}) {
open my $lfh, '<', $config{lcsaj_hits_file};
$lcsaj_hits = decode_json(do { local $/; <$lfh> });
close $lfh;
}
my $cpd_data;
if($config{cpd_file} && -f $config{cpd_file}) {
open my $cfh, '<', $config{cpd_file};
$cpd_data = decode_json(do { local $/; <$cfh> });
close $cfh;
}
my $files = _group_by_file($mutation_db);
push @html, @{_mutation_index($mutation_db, $files, $cover_db, $config{lcsaj_root}, $lcsaj_hits, $cpd_data)};
# Pre-sort files worst-first so navigation order matches index order
my @sorted_files = sort { _file_score($files->{$a}) <=> _file_score($files->{$b}) || $a cmp $b } keys %$files;
for my $i (0 .. $#sorted_files) {
my $file = $sorted_files[$i];
# Only assign previous if this is NOT the first file
my $prev = $i > 0 ? $sorted_files[$i - 1] : undef;
# Only assign next if this is NOT the last file
my $next = $i < $#sorted_files ? $sorted_files[$i + 1] : undef;
_mutant_file_report($config{mutation_output_dir}, $file, $files->{$file}, $prev, $next, $cover_db, $config{lcsaj_root}, $lcsaj_hits, $cpd_data);
}
if($cpd_data) {
my @cpd_files = sort keys %$cpd_data;
for my $i (0 .. $#cpd_files) {
_cpd_file_report(
$config{cpd_output_dir}, $cpd_files[$i], $cpd_data, $github_base,
$i > 0 ? $cpd_files[$i - 1] : undef,
$i < $#cpd_files ? $cpd_files[$i + 1] : undef,
);
}
}
}
my $timestamp = 'Unknown';
if(my $stat = stat($config{cover_db})) {
$timestamp = strftime('%Y-%m-%d %H:%M:%S', localtime($stat->mtime));
}
# Get ATG version for dashboard footer — search @INC for the installed module
my $atg_version = 'unknown';
my $module_file = $INC{'App/Test/Generator.pm'};
unless($module_file) {
# Module not yet loaded; search @INC directly
for my $dir (@INC) {
my $candidate = "$dir/App/Test/Generator.pm";
if(-f $candidate) {
$module_file = $candidate;
last;
}
}
}
# Fall back to the source tree path for ATG's own development environment
$module_file //= $config{module_file};
if($module_file && open(my $fh, '<', $module_file)) {
while(<$fh>) {
if(/our\s+\$VERSION\s*=\s*['"]([^'"]+)['"]/) {
$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
bin/test-generator-index view on Meta::CPAN
$ter_cell = "$ter1_badge / $ter2_badge / $ter3_badge";
} else {
# LCSAJ not configured — show TER1/TER2 only
my $ter1_badge = _ter_badge($ter1_pct, 'n/a');
my $ter2_badge = _ter_badge($ter2_pct, 'n/a');
$ter_cell = "$ter1_badge / $ter2_badge";
}
# --------------------------------------------------
# CPD column — percentage of file lines that appear
# in at least one duplicate block.
# --------------------------------------------------
my $cpd_cell = '';
if($cpd_data) {
my $cpd_blocks = _cpd_blocks_for_file($file, $cpd_data);
my $dup_pct = _cpd_pct_for_file($file, $cpd_data);
# Invert badge colours: high duplication is bad (red), low is good (green)
my $cpd_badge = _dup_badge($dup_pct);
if(@$cpd_blocks) {
(my $cpd_display = $file) =~ s{^.*/lib/}{lib/};
my $cpd_url = "cpd_html/$cpd_display.html";
$cpd_badge .= qq{ <a href="$cpd_url" class="icon-link" title="View duplicate lines highlighted" target="_blank">🔍</a>};
}
$cpd_cell = "<td>$cpd_badge</td>";
}
push @html, sprintf(
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><td>%s</td>%s</tr>},
$row_class,
$html_file,
$file,
$source_link,
$total,
$killed,
$survived,
$skipped,
$badge_html,
$complexity_html,
$ter_cell,
$cpd_cell,
);
}
push @html, "</tbody></table>\n";
unless($cpd_data) {
push @html, '<p><em>Install <a href="https://metacpan.org/dist/Code-CutNPaste">Code::CutNPaste</a> to enable copy-paste duplication analysis (Dup% column).</em></p>';
}
# --------------------------------------------------
# Duplication Report table — lists every duplicate
# block with its file, line range, and the file/line
# it duplicates, so the reader can see exactly which
# lines are copied without clicking into each file.
# --------------------------------------------------
if($cpd_data && %$cpd_data) {
# Change 5: staleness warning — compare cpd.json mtime to
# the newest .pm under lib/ so stale results are flagged.
if($config{cpd_file} && -f $config{cpd_file}) {
my $cpd_mtime = (stat($config{cpd_file}))[9] // 0;
my $newest_pm = 0;
if(opendir my $dh, 'lib') {
# Recursive mtime scan via find(1) kept dependency-free
my @pm_files;
my @dirs = ('lib');
while(my $dir = shift @dirs) {
next unless opendir(my $d, $dir);
for my $e (readdir $d) {
next if $e =~ /^\./;
my $path = "$dir/$e";
push @dirs, $path if -d $path;
if($e =~ /\.pm$/) {
my $mt = (stat($path))[9] // 0;
$newest_pm = $mt if $mt > $newest_pm;
}
}
closedir $d;
}
closedir $dh;
}
if($newest_pm > $cpd_mtime) {
push @html, '<p class="notice" style="background:#fff3cd;border:1px solid #ffc107;border-radius:4px;padding:6px 10px;">'
. '⚠ CPD data may be stale — source files have changed since the last duplication scan. '
. 'Re-run the dashboard workflow to refresh.</p>';
}
}
push @html, '<h2>Duplication Report</h2>';
push @html, "<p><em>Only duplicate blocks of 10 or more consecutive lines are shown. "
. "Each pair is listed once. Intra-file duplicates are labelled <b>(same file)</b>.</em></p>\n";
push @html, "<table border='1' cellpadding='5' class=\"sortable-table dup-table\" data-sort-col=\"0\" data-sort-order=\"asc\" data-table-id=\"dup\">\n";
push @html, <<"THEAD";
<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">Lines (10+ consecutive)</span> <span class="arrow">▲</span></th>
<th class="sortable" onclick="sortTable(this, 2)"><span class="label">Duplicated in</span> <span class="arrow">▲</span></th>
</tr>
</thead>
<tbody>
THEAD
# Change 4: sort files by filtered block count descending, then name.
my %filtered_blocks;
for my $f (keys %$cpd_data) {
$filtered_blocks{$f} = _cpd_blocks_for_file($f, $cpd_data);
}
# Change 1: deduplicate pairs — track canonical (side_a, side_b) pairs.
my %seen_pairs;
for my $f (sort { scalar @{$filtered_blocks{$b}} <=> scalar @{$filtered_blocks{$a}} || $a cmp $b } keys %$cpd_data) {
my $blocks = $filtered_blocks{$f};
next unless ref $blocks eq 'ARRAY' && @$blocks;
my $display_f = $f;
$display_f =~ s{^.*/lib/}{lib/};
my $source_url = $github_base . $display_f;
my $drill_url = "cpd_html/$display_f.html";
my $file_cell = sprintf(
'<a href="%s" title="View duplicate lines highlighted" target="_blank">%s</a>'
. ' <a href="%s" class="icon-link" title="View source on GitHub" target="_blank">🔍</a>',
$drill_url, $display_f, $source_url
);
for my $b (sort { $a->{start} <=> $b->{start} } @$blocks) {
next unless ref $b eq 'HASH' && defined $b->{start};
my $end = $b->{end} // $b->{start};
next if ($end - $b->{start} + 1) < 10;
my $mf = $b->{match_file} // '';
$mf =~ s{^.*/lib/}{lib/};
my $ml = $b->{match_line} // '';
# Change 1: canonical pair key — deduplicate A↔B and B↔A
my $side_a = "$display_f:$b->{start}";
( run in 2.037 seconds using v1.01-cache-2.11-cpan-4ac696b4eb4 )