App-Test-Generator
view release on metacpan or search on metacpan
bin/test-generator-index view on Meta::CPAN
# 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';
bin/test-generator-index view on Meta::CPAN
# 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}.
bin/test-generator-index view on Meta::CPAN
# _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.
bin/test-generator-index view on Meta::CPAN
}
# --------------------------------------------------
# _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.
#
# --------------------------------------------------
bin/test-generator-index view on Meta::CPAN
# --------------------------------------------------
# _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.
#
bin/test-generator-index view on Meta::CPAN
# --------------------------------------------------
# _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.
#
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# signature expression in an isolated
# environment to extract parameter
# metadata without polluting the
# current process.
#
# Entry: $function - function name string.
# $signature_expr - Type::Params
# signature expression
# string.
#
# Exit: Returns a decoded JSON hashref
# containing parameters and returns
# metadata on success.
# Croaks on unsafe expressions, timeout,
# or compile errors.
#
# Side effects: May fork a child process with a
# memory limit applied via
# BSD::Resource if available.
# Memory limiting is best-effort and
# silently skipped on platforms where
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# --------------------------------------------------
# _build_schema_from_meta
#
# Purpose: Convert the parameter and return type
# metadata produced by
# _compile_signature_isolated into a
# standard schema hashref.
#
# Entry: $meta - hashref with 'parameters'
# arrayref and optional
# 'returns' hashref, as decoded
# from the isolated compile
# JSON output.
#
# Exit: Returns a schema hashref with input,
# output, style, source, _notes, and
# _confidence keys.
#
# Side effects: None.
#
# Notes: Unknown Type::Params type names are
# to temporary files.
BEGIN {
use_ok('App::Test::Generator::LCSAJ');
use_ok('App::Test::Generator::LCSAJ::Coverage');
}
# ---------------------------------------------------------------
# Helper: write a temporary .pm file containing the given source,
# then call generate() into a temporary output directory.
# Returns ($paths, $decoded, $json_file, $pm, $out_dir).
# $paths — in-memory arrayref returned by generate()
# $decoded — deserialised JSON array from the written file
# $json_file — absolute path of the written .lcsaj.json file
# $pm — absolute path of the temporary .pm file
# $out_dir — output directory used
# ---------------------------------------------------------------
sub _generate_for_source {
my ($source, $out_dir) = @_;
my $tmpdir = tempdir(CLEANUP => 1);
my $lib = File::Spec->catdir($tmpdir, 'lib');
mkdir $lib or die "Cannot mkdir $lib: $!";
require Cwd;
my $orig = Cwd::cwd();
chdir $tmpdir or die "Cannot chdir $tmpdir: $!";
# Use relative paths so LCSAJ output paths are portable
my $rel_pm = File::Spec->catfile('lib', 'TestModule.pm');
my $rel_out = $out_dir // 'out';
mkdir $rel_out unless -d $rel_out;
my $paths = App::Test::Generator::LCSAJ->generate($rel_pm, $rel_out);
my $json_dir = File::Spec->catdir($rel_out, 'TestModule.pm.lcsaj');
my $json_file = File::Spec->catfile($json_dir, 'TestModule.pm.lcsaj.json');
my $decoded;
if(-f $json_file) {
open my $jfh, '<', $json_file or die "Cannot read $json_file: $!";
$decoded = decode_json(do { local $/; <$jfh> });
close $jfh;
}
chdir $orig;
return ($paths, $decoded, File::Spec->catfile($tmpdir, $json_file), $pm, $rel_out);
}
# ---------------------------------------------------------------
# 1. Simple linear sub — no branches.
# All statements in a single block; every path record must
# have defined start, end and target.
# ---------------------------------------------------------------
subtest 'simple linear sub produces valid (possibly empty) path list' => sub {
my $src = <<'END_PM';
package TestModule;
sub foo {
my $x = 1;
my $y = 2;
return $x + $y;
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
# generate() must return an arrayref
isa_ok($paths, 'ARRAY', 'generate() return value');
# The serialised JSON must also be an arrayref
isa_ok($decoded, 'ARRAY', 'decoded JSON');
# A branchless sub has no jumps so produces no LCSAJ paths — this is correct
# Any paths that are present must have defined bounds
my @null_bounds = grep { !defined $_->{start} || !defined $_->{end} } @{$decoded};
is(scalar(@null_bounds), 0, 'no null-bounds paths');
};
# ---------------------------------------------------------------
# 2. Sub with an if/else branch.
# The true and false successor blocks each produce paths;
# all must have defined bounds.
# ---------------------------------------------------------------
subtest 'if/else branching sub produces paths with defined bounds' => sub {
my $src = <<'END_PM';
sub bar {
my $x = shift;
if($x > 0) {
return 'positive';
} else {
return 'non-positive';
}
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
ok(scalar(@{$decoded}) > 0, 'at least one path emitted');
my @null_bounds = grep { !defined $_->{start} || !defined $_->{end} } @{$decoded};
is(scalar(@null_bounds), 0, 'no null-bounds paths');
};
# ---------------------------------------------------------------
# 3. Trailing-branch sub — branch is the last statement.
# This is the exact regression pattern that previously produced
# a path with null start/end from an empty successor block.
# ---------------------------------------------------------------
subtest 'trailing branch produces no null-bounds paths' => sub {
my $src = <<'END_PM';
package TestModule;
sub baz {
my $x = 1;
if($x) { return 1 }
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
my @null_bounds = grep { !defined $_->{start} || !defined $_->{end} } @{$decoded};
is(scalar(@null_bounds), 0, 'trailing-branch sub: no null-bounds paths');
};
# ---------------------------------------------------------------
# 4. Deduplication — identical paths must appear only once in the
# serialised JSON output.
# ---------------------------------------------------------------
subtest 'no duplicate paths in serialised output' => sub {
my $src = <<'END_PM';
package TestModule;
sub quux {
my $x = shift;
if($x) { return $x }
return 0;
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
my %seen;
my @dupes;
# Build a signature for each path and collect any repeats
for my $p (@{$decoded}) {
my $sig = join(':', map { $_ // 'undef' }
$p->{start}, $p->{end}, $p->{target});
push @dupes, $sig if $seen{$sig}++;
}
is(scalar(@dupes), 0, 'no duplicate path records')
or diag('Duplicate paths: ', join(', ', @dupes));
};
# ---------------------------------------------------------------
# 5. Output file is created at the expected path.
# generate() must write:
# <out_dir>/TestModule.pm.lcsaj/TestModule.pm.lcsaj.json
# ---------------------------------------------------------------
subtest 'output JSON file is written to expected path' => sub {
my $src = <<'END_PM';
package TestModule;
sub simple { return 1 }
1;
END_PM
my ($paths, $decoded, $json_file) = _generate_for_source($src);
ok(-f $json_file, "JSON file exists at $json_file");
};
# ---------------------------------------------------------------
# 6. Module with no subroutines produces an empty path list and
# an empty JSON array.
# ---------------------------------------------------------------
subtest 'module with no subs produces empty path list' => sub {
my $src = <<'END_PM';
package TestModule;
our $VERSION = 1;
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
is(scalar(@{$decoded}), 0, 'empty path list for sub-free module');
};
# ---------------------------------------------------------------
# 7. generate() croaks when passed a non-existent file path.
# ---------------------------------------------------------------
subtest 'generate() croaks on non-existent file' => sub {
throws_ok(
sub { App::Test::Generator::LCSAJ->generate('/no/such/file.pm') },
qr/Cannot parse/,
'croaks with "Cannot parse" message for missing file',
my $a = 1;
return $a;
}
sub beta {
my $b = shift;
if($b) { return $b }
return 0;
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
# alpha contributes at least one path, beta at least two
ok(scalar(@{$decoded}) >= 3, 'paths from both subs present')
or diag('Got ' . scalar(@{$decoded}) . ' path(s)');
my @null_bounds = grep { !defined $_->{start} || !defined $_->{end} } @{$decoded};
is(scalar(@null_bounds), 0, 'no null-bounds paths across multiple subs');
};
# ---------------------------------------------------------------
# 10. All supported branch types — unless, while, for, foreach.
# Each should produce paths with defined bounds and no nulls.
# ---------------------------------------------------------------
subtest 'unless/while/for/foreach branch types produce valid paths' => sub {
for my $type (qw(unless while for foreach)) {
# Build a minimal sub whose only branch is of the given type
my $body;
if($type eq 'for' || $type eq 'foreach') {
$body = "my \@a = (1,2,3);\n\t$type my \$i (\@a) { last }\n\treturn 1;";
} elsif($type eq 'while') {
$body = "my \$x = 0;\n\t$type (\$x < 1) { \$x++ }\n\treturn \$x;";
} else {
$body = "my \$x = 1;\n\t$type (\$x) { return 0 }\n\treturn 1;";
}
my $src = "package TestModule;\nsub test_$type {\n\t$body\n}\n1;\n";
my ($paths, $decoded) = _generate_for_source($src);
my @null_bounds = grep {
!defined $_->{start} || !defined $_->{end}
} @{$decoded};
is(scalar(@null_bounds), 0, "$type: no null-bounds paths");
}
};
# ---------------------------------------------------------------
# 11. target defaults to 0 — when a target block id has no
# corresponding line in the id-to-line map, the path record
# must have target == 0 rather than undef.
# ---------------------------------------------------------------
subtest 'target defaults to 0 when target block has no lines' => sub {
# A trailing branch forces a successor block with no lines,
# exercising the // 0 fallback in _cfg_to_lcsaj.
my $src = <<'END_PM';
package TestModule;
sub target_zero {
my $x = shift;
if($x) { return $x }
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
my @undef_target = grep { !defined $_->{target} } @{$decoded};
is(scalar(@undef_target), 0, 'no undef target values — all default to 0');
};
# ---------------------------------------------------------------
# 12. Exact path count for a known simple branching sub.
# A sub with one if-branch produces exactly 2 paths.
# If _build_cfg mis-classifies non-branch stmts as branches
# (line 189 mutation) the count will be wrong.
# ---------------------------------------------------------------
subtest 'exact path count for single-branch sub' => sub {
my $src = <<'END_PM';
package TestModule;
sub one_branch {
my $x = shift;
my $y = 1;
if($x) { return $x }
return $y;
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
# One if-branch produces exactly 3 outgoing edges from the
# branch block — one for each successor
# The sub has a trailing statement after the if, so the CFG has three blocks: the pre-branch block, the true block, and the post-branch block.
is(scalar(@{$decoded}), 3, 'single-branch sub produces exactly 3 paths');
};
# ---------------------------------------------------------------
# 13. Fallthrough edge count — sequential blocks must be connected.
# A linear sub with no branches produces exactly 1 path.
# If the $i < $#blocks loop condition is wrong (line 208
# mutation) fallthrough edges are missing and paths = 0.
# ---------------------------------------------------------------
subtest 'linear sub with multiple statements produces exactly 1 path' => sub {
my $src = <<'END_PM';
package TestModule;
sub linear {
my $a = 1;
my $b = 2;
my $c = $a + $b;
return $c;
}
1;
END_PM
my ($paths, $decoded) = _generate_for_source($src);
# A purely linear sub with no branches has no outgoing edges at all (it's a leaf block), so _cfg_to_lcsaj skips it entirely and produces 0 paths.
is(scalar(@{$decoded}), 0, 'linear sub with no branches produces 0 paths (no jump = no LCSAJ)');
};
# ------------------------------------------------------------------
# Import private functions for direct white-box testing
# ------------------------------------------------------------------
{
no warnings 'once';
*_new_block = \&App::Test::Generator::LCSAJ::_new_block;
*_connect_blocks = \&App::Test::Generator::LCSAJ::_connect_blocks;
*_is_branch = \&App::Test::Generator::LCSAJ::_is_branch;
t/LCSAJ_unit.t view on Meta::CPAN
my $rel_pm = File::Spec->catfile('lib', 'TestModule.pm');
my $rel_out = $out_dir_name // 'out';
mkdir $rel_out unless -d $rel_out;
my $paths = App::Test::Generator::LCSAJ->generate($rel_pm, $rel_out);
my $json_dir = File::Spec->catdir($rel_out, 'TestModule.pm.lcsaj');
my $json_file = File::Spec->catfile($json_dir, 'TestModule.pm.lcsaj.json');
my $decoded;
if(-f $json_file) {
open my $jfh, '<', $json_file or die $!;
$decoded = decode_json(do { local $/; <$jfh> });
close $jfh;
}
chdir $orig;
return ($paths, $decoded, File::Spec->catfile($tmpdir, $json_file));
}
# ==================================================================
# generate()
#
# POD spec:
# Arguments: $class, $file (required), $out_dir (optional)
# Returns: arrayref of path hashrefs with keys start, end, target
# Side effect: writes .lcsaj.json to $out_dir
# Croaks: when file cannot be parsed
t/LCSAJ_unit.t view on Meta::CPAN
subtest 'generate() all path values are defined' => sub {
my $src = <<'END';
package TestModule;
sub foo {
my $x = shift;
if($x > 0) { return $x; }
return 0;
}
1;
END
my ($paths, $decoded) = _generate($src);
for my $p (@{$decoded}) {
ok(defined $p->{start}, 'start is defined');
ok(defined $p->{end}, 'end is defined');
ok(defined $p->{target}, 'target is defined');
}
};
subtest 'generate() writes JSON file at expected path' => sub {
my $src = "package TestModule;\nsub foo { return 1; }\n1;\n";
my (undef, undef, $json_file) = _generate($src);
ok(-f $json_file, "JSON file written at expected path");
};
subtest 'generate() JSON file contains a valid array' => sub {
my $src = "package TestModule;\nsub foo { return 1; }\n1;\n";
my (undef, $decoded) = _generate($src);
is(ref($decoded), 'ARRAY', 'JSON decodes to arrayref');
};
subtest 'generate() in-memory paths include at least as many as written JSON' => sub {
my $src = <<'END';
package TestModule;
sub foo {
my $x = shift;
if($x > 0) { return 1; }
return 0;
}
1;
END
my ($paths, $decoded) = _generate($src);
ok(scalar @{$paths} >= scalar @{$decoded}, 'in-memory count >= JSON count (JSON deduplicates)');
ok(scalar @{$decoded} >= 0, 'JSON contains a non-negative number of paths');
};
subtest 'generate() returns empty arrayref for module with no subs' => sub {
my $src = "package TestModule;\nour \$VERSION = 1;\n1;\n";
my ($paths, $decoded) = _generate($src);
is(scalar @{$decoded}, 0, 'no paths for sub-free module');
};
subtest 'generate() croaks for nonexistent file' => sub {
throws_ok(
sub { App::Test::Generator::LCSAJ->generate('/no/such/file.pm') },
qr/Cannot parse/,
'croaks with "Cannot parse" for missing file',
);
};
t/LCSAJ_unit.t view on Meta::CPAN
subtest 'generate() no duplicate paths in output' => sub {
my $src = <<'END';
package TestModule;
sub foo {
my $x = shift;
if($x) { return $x; }
return 0;
}
1;
END
my (undef, $decoded) = _generate($src);
my %seen;
my @dupes;
for my $p (@{$decoded}) {
my $sig = join ':', map { $_ // 'undef' }
$p->{start}, $p->{end}, $p->{target};
push @dupes, $sig if $seen{$sig}++;
}
is(scalar @dupes, 0, 'no duplicate path records in JSON output');
};
subtest 'generate() handles multiple subs in one file' => sub {
my $src = <<'END';
package TestModule;
t/LCSAJ_unit.t view on Meta::CPAN
my $a = shift;
return $a;
}
sub beta {
my $b = shift;
if($b) { return $b; }
return 0;
}
1;
END
my ($paths, $decoded) = _generate($src);
# beta has a branch so produces at least one path
ok(scalar @{$decoded} > 0, 'multiple subs: at least one path produced');
};
subtest 'generate() handles all supported branch types' => sub {
for my $type (qw(if unless while for foreach)) {
my $body;
if($type eq 'for' || $type eq 'foreach') {
$body = "my \@a = (1,2,3);\n\t$type my \$i (\@a) { last; }\n\treturn 1;";
} elsif($type eq 'while') {
$body = "my \$x = 0;\n\t$type (\$x < 1) { \$x++; }\n\treturn \$x;";
} else {
t/LCSAJ_unit.t view on Meta::CPAN
subtest 'generate() target key is never undef' => sub {
my $src = <<'END';
package TestModule;
sub trailing {
my $x = shift;
if($x) { return $x; }
}
1;
END
my (undef, $decoded) = _generate($src);
my @undef_targets = grep { !defined $_->{target} } @{$decoded};
is(scalar @undef_targets, 0, 'no undef target values in output');
};
done_testing();
( run in 1.059 second using v1.01-cache-2.11-cpan-df04353d9ac )