App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
# --------------------------------------------------
# Fix YAML::XS indentation quirks.
# YAML::XS does not reliably honour $Indent for:
# 1. List items nested inside hash values — they
# should be indented 2 more than their parent
# key but sometimes appear at the same level.
# 2. Top-level keys after a nested block — they
# sometimes lose their leading spaces entirely.
# We correct both by scanning line by line and
# tracking the expected indentation depth.
# --------------------------------------------------
my @lines = split /\n/, $yaml, -1;
my @fixed;
my $last_key_indent = 0;
for my $line (@lines) {
# Track indentation of the most recent hash key line
# so we know the expected depth for following list items
if($line =~ /^( *)[\w][^:]*:/) {
$last_key_indent = length($1);
}
# Fix list items that are not indented enough —
# they should be at least last_key_indent + 2
if($line =~ /^( *)- /) {
my $current = length($1);
my $expected = $last_key_indent + 2;
if($current < $expected) {
$line = (' ' x $expected) . substr($line, $current);
}
}
push @fixed, $line;
}
$yaml = join("\n", @fixed);
return $yaml;
}
# --------------------------------------------------
# _generate_mutant_tests
#
# Generate a test stub file for surviving mutants,
# to be placed in the project's t/ directory.
#
# This sub is called from test-generator-index which
# runs from the project root (e.g. CGI-Info/ or
# App-Test-Generator/). The t/ directory written to
# belongs to the project under test, not to
# App::Test::Generator itself.
#
# High/Medium difficulty survivors get TODO stubs.
# Low difficulty survivors get comment-only hints.
# Mutants on the same line are deduplicated into one
# stub listing all variants — one test kills them all.
# File is skipped entirely if nothing to report.
#
# Arguments:
# $mutation_db - decoded mutation JSON hashref
# $cover_db - decoded Devel::Cover JSON hashref
# $test_dir - directory to write the .t file (default: 'xt')
#
# Returns:
# The filename written, or undef if nothing written
# --------------------------------------------------
sub _generate_mutant_tests {
my ($mutation_db, $cover_db, $test_dir, $generate_test) = @_;
# Default output directory is the project's xt/ directory
$test_dir //= 'xt';
# --------------------------------------------------
# Separate survivors into high/med (need TODO stubs)
# and low (comment hints only), based on the
# 'difficulty' string field in the mutation data
# --------------------------------------------------
my @stub_mutants;
my @hint_mutants;
for my $m (@{ $mutation_db->{survived} || [] }) {
# Skip malformed entries missing required fields
next unless ref $m && defined $m->{file} && defined $m->{line};
# Route by difficulty string; default to stub if field is absent
if(defined $m->{difficulty} && $m->{difficulty} eq 'LOW') {
push @hint_mutants, $m;
} else {
push @stub_mutants, $m;
}
}
# Skip file creation entirely if there is nothing to report
return undef if !@stub_mutants && !@hint_mutants;
# --------------------------------------------------
# Group both sets by file then by line number.
# Multiple mutations on the same line are deduplicated
# into one stub — one good test kills all variants.
# --------------------------------------------------
my %stubs_by_file;
my %hints_by_file;
for my $m (@stub_mutants) {
push @{ $stubs_by_file{ $m->{file} }{ $m->{line} } }, $m;
}
for my $m (@hint_mutants) {
push @{ $hints_by_file{ $m->{file} }{ $m->{line} } }, $m;
}
# --------------------------------------------------
# Build sorted list of all affected source files
# --------------------------------------------------
my %all_files;
$all_files{$_}++ for keys %stubs_by_file, keys %hints_by_file;
my @files = sort keys %all_files;
# --------------------------------------------------
# Derive Perl module names from file paths for use_ok()
# e.g. lib/CGI/Info.pm -> CGI::Info
# lib/App/Test/Foo.pm -> App::Test::Foo
bin/test-generator-index view on Meta::CPAN
print "Generated mutant test stubs: $filename\n" if $config{verbose};
return $filename;
}
# --------------------------------------------------
# _is_class_method
#
# Purpose: Determine whether a named subroutine
# in a source file is a class method
# (receives $class as first arg) rather
# than an instance method ($self).
#
# Entry: $source_lines - arrayref of source lines
# $sub_name - name of the sub to check
#
# Exit: Returns 1 if class method, 0 otherwise.
# --------------------------------------------------
sub _is_class_method {
my ($source_lines, $sub_name) = @_;
# Find the start of the named sub
my $in_sub = 0;
for my $line (@{$source_lines}) {
if(!$in_sub && $line =~ /^\s*sub\s+\Q$sub_name\E\b/) {
$in_sub = 1;
next;
}
next unless $in_sub;
# Look for first argument extraction in the sub body
# Class method: my $class = shift / my ($class, ...
return 1 if $line =~ /my\s+\$class\s*=/;
return 1 if $line =~ /my\s*\(\s*\$class\b/;
# Instance method: my $self = shift / my ($self, ...
return 0 if $line =~ /my\s+\$self\s*=/;
return 0 if $line =~ /my\s*\(\s*\$self\b/;
# Stop scanning at end of sub
last if $line =~ /^\s*\}\s*$/;
}
return 0;
}
# --------------------------------------------------
# _generate_fuzz_schemas
#
# Scan t/conf/ for existing YAML schema
# files and augment copies of them with
# boundary values extracted from surviving
# NUM_BOUNDARY mutants whose enclosing sub
# matches the schema's function field.
# The original schema is never modified.
# Augmented copies are written with a
# timestamped mutant_fuzz_ prefix so they
# are picked up by t/fuzz.t automatically.
#
# Entry: $mutation_db - decoded mutation JSON
# hashref
# $test_dir - base test directory
# (default: 'xt')
#
# Exit: Returns the number of augmented schema
# files written. Returns 0 if no matching
# survivors were found.
#
# Side effects: Writes .yml files to $test_dir/conf/.
# Prints progress if $config{verbose}.
#
# Notes: Skips schemas whose filename starts with
# mutant_fuzz_ to avoid augmenting already-
# augmented schemas.
# Skips schemas where no matching NUM_BOUNDARY
# survivors exist, printing a verbose note.
# Merges new boundary values into whichever
# edge key already exists in the schema
# (edge_case_array or edge_cases), falling
# back to _boundary_edge_case_key detection
# if neither key is present yet.
# Deduplicates boundary values before writing.
# --------------------------------------------------
sub _generate_fuzz_schemas {
my ($mutation_db, $test_dir) = @_;
# Default test directory is the project's xt/ directory
$test_dir //= 'xt';
my $conf_dir = "$test_dir/conf";
my $written = 0;
# Nothing to do if t/conf/ does not exist yet
unless(-d $conf_dir) {
warn "No $conf_dir directory found, skipping fuzz schema generation" if $config{verbose};
return 0;
}
# --------------------------------------------------
# Compute a single timestamp for all files written
# in this run, consistent with mutant_YYYYMMDD.t
# naming used by _generate_mutant_tests
# --------------------------------------------------
my $timestamp = strftime('%Y%m%d_%H%M%S', localtime);
# --------------------------------------------------
# Build a lookup of surviving NUM_BOUNDARY mutants
# indexed by (normalised module name, function name)
# so we can find matches efficiently per schema
# --------------------------------------------------
my %survivors_by_mod_func;
for my $m (@{ $mutation_db->{survived} || [] }) {
# Only process NUM_BOUNDARY mutations — these have
# the clearest boundary value inference path
next unless ref $m;
next unless($m->{id} // '') =~ /NUM_BOUNDARY/;
next unless defined $m->{file} && defined $m->{line};
# Derive module name from file path for matching
bin/test-generator-index view on Meta::CPAN
input => \@die_inputs,
_STATUS => 'DIES',
} unless exists $augmented->{cases}{$die_label};
}
}
# --------------------------------------------------
# Build the output filename using the timestamp and
# function name, safe for use as a filesystem path
# --------------------------------------------------
(my $safe_func = $func) =~ s/[^A-Za-z0-9]/_/g;
my $out_name = "mutant_fuzz_${timestamp}_${safe_func}.yml";
my $out_path = "$conf_dir/$out_name";
# Skip if this exact file already exists —
# same guard used by _generate_mutant_tests
if(-f $out_path) {
print " Skipping $out_name: already exists\n"
if $config{verbose};
next;
}
# Serialise the augmented schema to a normalised YAML string
my $yaml = _dump_schema_yaml($augmented);
if(!defined $yaml) {
warn "YAML serialisation failed for $out_path";
next;
}
# Write the augmented schema file
open(my $fh, '>:encoding(UTF-8)', $out_path)
or do { warn "Cannot write $out_path: $!\n"; next };
print $fh $yaml;
close $fh;
$written++;
print " Generated fuzz schema: $out_path\n"
if $config{verbose};
}
# Report summary of what was written
printf "Generated %d fuzz schema file(s) in %s\n",
$written, $conf_dir
if $config{verbose};
return $written;
}
# --------------------------------------------------
# _mutation_index
#
# Purpose: Build the HTML mutation report section
# for the main dashboard page. Produces
# the mutation summary (score, totals),
# the per-file mutation files table with
# TER1/TER2/TER3 badges, and the
# structural coverage and executive
# summary blocks.
#
# Entry: $data - decoded mutation JSON
# hashref (score, total,
# killed, survived)
# $files - hashref of file =>
# { killed => [], survived => [] }
# as produced by _group_by_file
# $coverage_data - decoded Devel::Cover JSON
# hashref, or undef
# $lcsaj_dir - root directory for LCSAJ
# .json files, or undef
# $lcsaj_hits - hashref of LCSAJ hit data
# as produced by the runtime
# debugger, or undef
#
# Exit: Returns an arrayref of HTML strings
# ready to be pushed onto @html.
# Never returns undef.
#
# Notes: TER1 and TER2 are sourced from
# Devel::Cover via _coverage_for_file.
# TER3 is sourced from LCSAJ runtime data
# via _lcsaj_coverage_for_file.
# All three are normalised to lib/ paths
# at display time — neither data source
# is modified.
# The table is sorted worst-score-first
# so the files most needing attention
# appear at the top.
# --------------------------------------------------
sub _mutation_index {
my ($data, $files, $coverage_data, $lcsaj_dir, $lcsaj_hits) = @_;
my @html;
push @html, '<h2>Mutation Report</h2>';
push @html, '<h3>Mutation Summary</h3>';
push @html, '<ul>';
push @html, "<li><b>Score</b>: $data->{score}%</li>";
push @html, "<li><b>Total</b>: $data->{total}</li>";
push @html, '<li><b>Killed</b>: ', scalar(@{$data->{killed} || []}), '</li>';
push @html, '<li><b>Survived</b>: ', scalar(@{$data->{survived} || []}), '</li>';
push @html, '</ul>';
push @html, "<h3>Mutation Files</h3>\n";
push @html, "<table border='1' cellpadding='5'>\n";
# Column headers for the mutation files table.
# TER3 = Third level Test Effectiveness Ratio (LCSAJ path coverage).
# Only shown when lcsaj_root is configured.
if($config{lcsaj_root}) {
push @html, "<tr><th>File</th><th>Total</th><th>Killed</th><th>Survivors</th><th>Skipped</th><th>Score%</th><th>Complexity</th><th title=\"TER1=Statement, TER2=Branch, TER3=LCSAJ Path\">TER1 / TER2 / TER3</th></tr>\n";
} else {
push @html, "<tr><th>File</th><th>Total</th><th>Killed</th><th>Survivors</th><th>Skipped</th><th>Score%</th><th>Complexity</th></tr>\n";
}
for my $file (
sort { _file_score($files->{$a}) <=> _file_score($files->{$b}) || $a cmp $b } keys %$files
) {
my $killed = scalar @{ $files->{$file}{killed} || [] };
my $survived = scalar @{ $files->{$file}{survived} || [] };
my $skipped = $files->{$file}{skipped} // 0;
my $tested = $killed + $survived;
my $total = $tested + $skipped;
my $score = $tested ? sprintf('%.2f', ($killed / $tested) * 100) : 0;
bin/test-generator-index view on Meta::CPAN
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};
for my $m (@{$data->{$status}}) {
next unless ref $m;
next unless defined $m->{file};
push @{$files{$m->{file}}{$status}}, $m;
}
}
# Propagate per-file skipped line counts from MUTANT_SKIP annotations
if($data->{skipped}) {
for my $file (keys %{$data->{skipped}}) {
$files{$file}{skipped} = $data->{skipped}{$file};
}
}
return \%files;
}
# --------------------------------------------------
# _mutant_file_report
#
# Purpose: Generate a standalone per-file HTML
# mutation heatmap page, showing each
# source line colour-coded by mutation
# status (survived/killed/uncovered),
# with expandable mutant details,
# LCSAJ path markers, and navigation
# links to adjacent files.
#
# Entry: $dir - output directory for
# the HTML file
# $file - path to the source file
# $mutants - hashref of survived/killed
# mutant lists for this file
# $prev - path of the previous file
# for navigation, or undef
# $next - path of the next file
# for navigation, or undef
# $coverage_data - Devel::Cover JSON hashref
# or undef
# $lcsaj_dir - LCSAJ data root directory
# or undef
bin/test-generator-index view on Meta::CPAN
padding: 4px 8px;
border-radius: 4px;
font-size: 11px;
white-space: nowrap;
position: fixed;
z-index: 9999;
pointer-events: none;
}
.lcsaj-tip:hover .lcsaj-tip-text {
visibility: visible;
}
</style>
</head>
<body>
<button class="toggle" onclick="toggleTheme()">🌙 Toggle Theme</button>
};
}
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.
# $file - path to the source file as
# used elsewhere in the script
# (may be relative, blib-prefixed,
# or absolute).
#
# Exit: Returns the per-file coverage hashref
# from $cov->{summary} on success, or
# undef if no match is found.
#
# Side effects: None.
#
# Notes: Match strategies tried in order:
# 1. Exact key match
# 2. Basename match across all keys
# 3. lib/-relative path
# 4. blib/lib/-prefixed path
# The basename fallback is intentionally
# broad — it will return the first file
# whose basename matches, so it may
# produce incorrect results if two files
# share a basename in different
# directories.
# --------------------------------------------------
sub _coverage_for_file {
my ($cov, $file) = @_;
return unless $cov && $cov->{summary};
my $summary = $cov->{summary};
# 1. exact match (what worked before)
return $summary->{$file} if exists $summary->{$file};
my $base = basename($file);
# 2. basename match (what worked before)
for my $k (keys %$summary) {
next if $k eq 'Total';
if(basename($k) eq $base) {
return $summary->{$k};
}
}
# 3. try lib/ relative path
my $rel = $file;
$rel =~ s{.*?/lib/}{lib/};
return $summary->{$rel} if exists $summary->{$rel};
# 4. NEW: try blib/lib version
my $blib = "blib/$rel";
return $summary->{$blib} if exists $summary->{$blib};
return;
}
# --------------------------------------------------
# _cyclomatic_complexity
#
# Purpose: Compute an approximate cyclomatic
( run in 0.816 second using v1.01-cache-2.11-cpan-df04353d9ac )