CGI-Info
view release on metacpan or search on metacpan
scripts/generate_index.pl 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 generate_index.pl 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: 't')
#
# 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 t/ directory
$test_dir //= 't';
# --------------------------------------------------
# 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
scripts/generate_index.pl view on Meta::CPAN
# and skip the TODO stub for this mutant
my $written = _write_mutant_schema(
$schema, $test_dir, $mod,
$sub_name, $timestamp
);
if($written) {
print $fh "# SCHEMA GENERATED: $written\n";
print $fh "# (runnable test via t/fuzz.t)\n\n";
next; # Skip TODO stub for this mutant
}
# Fall through to stub if write failed
}
# Fall through to stub if extraction failed
# or confidence was too low
}
}
# Emit as commented-out stub — uncomment and complete to use
print $fh "# --- LOW HINT: $id $location ---\n";
print $fh "# Source: $source\n" if $source;
print $fh "# Hint: $hint\n";
print $fh "# Mutations on this line ($variant_label):\n";
# List each distinct mutation description
for my $v (@variants) {
print $fh "# $v->{description}\n";
}
print $fh $env_hint if $env_hint;
print $fh "# NOTE: new() called with no arguments as a starting point.\n";
print $fh "# If $mod requires constructor arguments, add them here.\n";
print $fh "# my \$obj = new_ok('${mod}');\n";
print $fh "# ok(\$obj->..., '$id: add assertion here');\n\n";
}
}
}
# Standard TAP footer
print $fh "done_testing();\n";
close $fh;
print "Generated mutant test stubs: $filename\n" if $config{verbose};
return $filename;
}
# --------------------------------------------------
# _generate_fuzz_schemas
#
# Purpose: 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: 't')
#
# 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 t/ directory
$test_dir //= 't';
my $conf_dir = "$test_dir/conf";
my $written = 0;
# Nothing to do if t/conf/ does not exist yet
unless(-d $conf_dir) {
print "No $conf_dir directory found, skipping fuzz schema generation\n" 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
scripts/generate_index.pl view on Meta::CPAN
# } unless exists $augmented->{cases}{$live_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;
}
# Mutant helpers from App::Test::Generator::Report::HTML
# --------------------------------------------------
# _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;
# print $out _header('Mutation Report');
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>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>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 $total = $killed + $survived;
my $score = $total ? sprintf('%.2f', ($killed / $total) * 100) : 0;
my $badge_class = $score >= $config{med_threshold} ? 'badge-good'
( run in 1.313 second using v1.01-cache-2.11-cpan-39bf76dae61 )