File Coverage

File:blib/lib/App/Test/Generator/Mutator.pm
Coverage:96.5%

linestmtbrancondsubtimecode
1package App::Test::Generator::Mutator;
2
3
15
15
161987
24
use 5.036;
4
15
15
15
1136
38553
54
use autodie qw(:io);    # covers open/close/read/write; excludes system (which legitimately fails)
5
15
15
15
34221
10
398
use Carp qw(croak);
6
15
15
15
25
18
309
use Config;
7
15
15
15
3584
48684
508
use File::Copy::Recursive qw(dircopy);
8
15
15
15
41
12
142
use File::Spec;
9
15
15
15
875
13928
274
use File::Temp qw(tempdir);
10
15
15
15
2867
807218
253
use PPI;
11
15
15
15
735
4772
387
use Readonly;
12
13
15
15
15
3075
19
198
use App::Test::Generator::Mutation::BooleanNegation;
14
15
15
15
2140
20
172
use App::Test::Generator::Mutation::ConditionalInversion;
15
15
15
15
2119
21
169
use App::Test::Generator::Mutation::NumericBoundary;
16
15
15
15
2171
18
9460
use App::Test::Generator::Mutation::ReturnUndef;
17
18# --------------------------------------------------
19# Valid mutation level values
20# --------------------------------------------------
21Readonly my $LEVEL_FULL => 'full';
22Readonly my $LEVEL_FAST => 'fast';
23
24# --------------------------------------------------
25# Default values for optional constructor arguments
26# --------------------------------------------------
27Readonly my $DEFAULT_LIB_DIR        => 'lib';
28Readonly my $DEFAULT_MUTATION_LEVEL => $LEVEL_FULL;
29
30# --------------------------------------------------
31# Error message constants — named so test code can
32# match against them without duplicating the literal
33# --------------------------------------------------
34Readonly my $ERR_FILE_REQUIRED     => 'file required';
35Readonly my $ERR_WORKSPACE_NOT_SET => 'Workspace not prepared -- call prepare_workspace first';
36Readonly my $ERR_RELATIVE_NOT_SET  => 'Relative path not set -- call prepare_workspace first';
37
38our $VERSION = '0.46';
39
40 - 166
=head1 NAME

App::Test::Generator::Mutator - Generate and apply mutation tests

=head1 VERSION

Version 0.46

=head1 SYNOPSIS

    use App::Test::Generator::Mutator;

    my $mutator = App::Test::Generator::Mutator->new(
        file           => 'lib/My/Module.pm',
        lib_dir        => 'lib',
        mutation_level => 'fast',
    );

    my $mutants = $mutator->generate_mutants();
    printf "Generated %d mutants\n", scalar @{$mutants};

    my $workspace = $mutator->prepare_workspace();

    for my $m (@{$mutants}) {
        $mutator->apply_mutant($m);
        if($mutator->run_tests()) {
            print "SURVIVED: ${\$m->description}\n";
        } else {
            print "KILLED:   ${\$m->description}\n";
        }
    }

=head1 DESCRIPTION

B<App::Test::Generator::Mutator> is a mutation engine that programmatically
alters Perl source files to evaluate the effectiveness of a project's test
suite. It analyses modules, generates systematic code mutations (such as
conditional inversions, logical operator changes, and numeric boundary
flips), and applies them within an isolated workspace so tests can be
executed safely against each modified variant.

By tracking which mutants are killed (cause tests to fail) versus those that
survive (tests still pass), the module enables calculation of a mutation
score, providing a quantitative measure of how well the test suite detects
unintended behavioural changes.

=head2 new

Construct a new Mutator for a given source file.

    my $mutator = App::Test::Generator::Mutator->new(
        file           => 'lib/My/Module.pm',
        lib_dir        => 'lib',
        mutation_level => 'full',
    );

=head3 Arguments

=over 4

=item * C<file>

Path to the Perl source file to mutate. Required. Must exist on disk.

=item * C<lib_dir>

Root library directory. Optional - defaults to C<lib>.

=item * C<mutation_level>

Controls the breadth of mutation. C<full> applies all mutations;
C<fast> deduplicates and removes redundant mutants first.
Optional - defaults to C<full>.

=back

=head3 Returns

A blessed hashref. Croaks if C<file> is missing or does not exist.

=head3 API specification

=head4 input

    {
        file           => { type => SCALAR },
        lib_dir        => { type => SCALAR, optional => 1 },
        mutation_level => { type => SCALAR, optional => 1 },
    }

=head4 output

    {
        type => OBJECT,
        isa  => 'App::Test::Generator::Mutator',
    }

=head3 EXAMPLE

    my $m = App::Test::Generator::Mutator->new(
        file           => 'lib/Acme/Widget.pm',
        mutation_level => 'fast',
    );

=head3 MESSAGES

=over 4

=item C<file required>

C<file> was not supplied.

=item C<< file not found: PATH >>

C<file> was supplied but does not exist on disk.

=back

=head3 FORMAL SPECIFICATION

Pre:  C<file> is defined ∧ C<-f file>

Post: C<ref(result) eq 'App::Test::Generator::Mutator'>
      âˆ§ C<result-E<gt>{file} eq file>
      âˆ§ C<result-E<gt>{mutation_level} ∈ {full, fast}>

=cut
167
168sub new {
169
125
708952
        my ($class, %args) = @_;
170
171        # file is required and must exist on disk
172
125
470
        croak $ERR_FILE_REQUIRED unless defined $args{file};
173
119
890
        croak "file not found: $args{file}" unless -f $args{file};
174
175        return bless {
176                file           => $args{file},
177                lib_dir        => $args{lib_dir}        || $DEFAULT_LIB_DIR,
178
113
977
                mutation_level => $args{mutation_level} || $DEFAULT_MUTATION_LEVEL,
179
180                # Instantiate all registered mutation strategies
181                mutations => [
182                        App::Test::Generator::Mutation::BooleanNegation->new(),
183                        App::Test::Generator::Mutation::ReturnUndef->new(),
184                        App::Test::Generator::Mutation::NumericBoundary->new(),
185                        App::Test::Generator::Mutation::ConditionalInversion->new(),
186                ],
187        }, $class;
188}
189
190 - 281
=head2 generate_mutants

Parse the target file and generate all mutants by running each registered
mutation strategy against the PPI document.

    my $mutants = $mutator->generate_mutants();   # scalar context → arrayref
    for my $m (@{$mutants}) { ... }

    my @mutants = $mutator->generate_mutants();   # list context → flat list (backward-compat)

=head3 Arguments

None beyond C<$self>.

=head3 Returns

An arrayref of L<App::Test::Generator::Mutant> objects. In C<fast> mode,
redundant and duplicate mutants are removed before returning.
Lines within C<## MUTANT_SKIP_BEGIN> / C<## MUTANT_SKIP_END> annotation
blocks are excluded from the candidate list entirely.
After this method returns,
C<$self-E<gt>{skip_lines}> contains a hashref mapping excluded
line numbers to 1.

=head3 API specification

=head4 input

    {
        self => { type => OBJECT, isa => 'App::Test::Generator::Mutator' },
    }

=head4 output

    {
        type     => ARRAYREF,
        elements => { type => OBJECT, isa => 'App::Test::Generator::Mutant' },
    }

=head3 EXAMPLE

    my $mutants = $mutator->generate_mutants();
    printf "%d mutants generated\n", scalar @{$mutants};

    for my $m (@{$mutants}) {
        printf "line %d: %s\n", $m->line, $m->description;
    }

=head3 MESSAGES

=over 4

=item C<< Unable to parse FILE >>

PPI could not parse the source file (syntax error or unreadable file).
FILE is the path passed to C<new>.

=item C<< FILE: MUTANT_SKIP_BEGIN at line N with no prior MUTANT_SKIP_END >>

A C<## MUTANT_SKIP_BEGIN> marker was found while already inside a skip block.

=item C<< FILE: MUTANT_SKIP_END at line N with no matching MUTANT_SKIP_BEGIN >>

A C<## MUTANT_SKIP_END> marker was found with no preceding C<## MUTANT_SKIP_BEGIN>.

=item C<< FILE: MUTANT_SKIP_BEGIN at line N has no matching MUTANT_SKIP_END >>

The source file ended while still inside a skip block.

=back

=head3 FORMAL SPECIFICATION

Pre:  C<prepare_workspace> need not have been called before this method.

Post: C<ref(result) eq 'ARRAY'>
      âˆ§ C<∀ m ∈ result: ref(m) eq 'App::Test::Generator::Mutant'>
      âˆ§ C<∀ m ∈ result: ¬ skip_lines{m->line}>

=head3 PSEUDOCODE

    parse file with PPI
    scan lines for MUTANT_SKIP_BEGIN / MUTANT_SKIP_END pairs → skip_lines
    for each registered mutation strategy:
        skip if strategy does not apply_to(doc)
        for each mutant from strategy->mutate(doc):
            include unless mutant.line ∈ skip_lines
    if mutation_level == 'fast':
        deduplicate and remove redundant mutants
    return arrayref (or flat list in list context)

=cut
282
283sub generate_mutants {
284
71
30235
        my $self = $_[0];
285
286        # Parse the target file into a PPI document
287
71
524
        my $doc = PPI::Document->new($self->{file}) or croak "Unable to parse $self->{file}";
288
289        # Build set of lines excluded by ## MUTANT_SKIP_BEGIN / ## MUTANT_SKIP_END
290
71
437366
        my %skip_lines;
291
71
117
        my $in_skip  = 0;
292
71
74
        my $skip_start = 0;
293
71
101
        my $line_num = 0;
294
295
71
212
        for my $line (split /\n/, $doc->serialize()) {
296
1841
39107
                $line_num++;
297
298                # Match only lines where the annotation is the entire content —
299                # prevents false positives in comments or POD that mention the tag
300
1841
1398
                if($line =~ /^\s*##\s*MUTANT_SKIP_BEGIN\s*$/) {
301
10
37
                        croak "$self->{file}: MUTANT_SKIP_BEGIN at line $line_num with no prior MUTANT_SKIP_END"
302                                if $in_skip;
303
8
18
                        $in_skip    = 1;
304
8
7
                        $skip_start = $line_num;
305                }
306
1839
1240
                $skip_lines{$line_num} = 1 if $in_skip;
307
308                # Match only lines where the annotation is the entire content —
309                # prevents false positives in comments or POD that mention the tag
310
1839
1455
                if($line =~ /^\s*##\s*MUTANT_SKIP_END\s*$/) {
311
6
36
                        croak "$self->{file}: MUTANT_SKIP_END at line $line_num with no matching MUTANT_SKIP_BEGIN"
312                                unless $in_skip;
313
3
4
                        $in_skip = 0;
314                }
315        }
316        # Unclosed MUTANT_SKIP_BEGIN is fatal
317
66
216
        croak "$self->{file}: MUTANT_SKIP_BEGIN at line $skip_start has no matching MUTANT_SKIP_END" if $in_skip;
318
319        # Store skip lines for use by the report generator
320
63
148
        $self->{skip_lines} = \%skip_lines;
321
322
63
68
        my @mutants;
323
324        # Run each registered mutation strategy against the document,
325        # excluding any candidates on skip-annotated lines. applies_to()
326        # is a cheap pre-filter -- skip the mutate() walk entirely for
327        # strategies that have nothing to match in this document.
328
63
63
77
116
        for my $mutation (@{$self->{mutations}}) {
329
252
848
                next unless $mutation->applies_to($doc);
330
194
795
487
783
                push @mutants, grep { !$skip_lines{$_->line} } $mutation->mutate($doc);
331        }
332
333        # In fast mode deduplicate and remove redundant mutants before returning.
334        # Returns arrayref in scalar context and a flat list in list context so
335        # existing callers (my @m = generate_mutants()) continue to work unchanged.
336
63
334
        my $result = $self->{mutation_level} eq $LEVEL_FAST
337                ? _dedup_mutants(\@mutants)
338                : \@mutants;
339
340
63
52
406
203
        return wantarray ? @{$result} : $result;
341}
342
343 - 420
=head2 prepare_workspace

Prepare an isolated temporary workspace for a single mutation test run.

The entire C<lib_dir> tree is copied into the workspace so that all module
dependencies resolve correctly when the test suite runs against the mutant.
Only after this copy is complete is the single target file overwritten by
C<apply_mutant>.

    my $workspace = $mutator->prepare_workspace();
    $mutator->apply_mutant($mutant);
    local $ENV{PERL5LIB} = "$workspace/lib";
    my $survived = (system('prove', 't') == 0);

=head3 Arguments

None beyond C<$self>.

=head3 Returns

A string containing the absolute path to the temporary directory created.
The directory is automatically removed when the object goes out of scope
via L<File::Temp>'s C<CLEANUP =E<gt> 1> behaviour.

=head3 Side effects

Creates a temporary directory. Recursively copies C<lib_dir> into it.
Sets C<< $self->{_workspace} >>, C<< $self->{_relative} >>, and
C<< $self->{_lib_basename} >>. Does not modify C<< $self->{lib_dir} >>.

=head3 Notes

Call C<prepare_workspace> once per file, then C<apply_mutant> once per
mutant within that file. Do not store the returned path beyond the
lifetime of the enclosing scope.

=head3 API specification

=head4 input

    {
        self => { type => OBJECT, isa => 'App::Test::Generator::Mutator' },
    }

=head4 output

    {
        type => SCALAR,
    }

=head3 EXAMPLE

    my $workspace = $mutator->prepare_workspace();
    # workspace is an absolute temp dir path
    # original lib_dir value is unchanged
    printf "original lib_dir still: %s\n", $mutator->{lib_dir};

=head3 MESSAGES

=over 4

=item C<dircopy failed: $!>

The C<lib_dir> tree could not be copied into the temporary workspace directory,
usually a permissions error.

=back

=head3 FORMAL SPECIFICATION

Pre:  C<-d self-E<gt>{lib_dir}>
      âˆ§ C<self-E<gt>{file}> begins with C<self-E<gt>{lib_dir}>

Post: C<-d result>
      âˆ§ C<self-E<gt>{_workspace} eq result>
      âˆ§ C<self-E<gt>{lib_dir}> unchanged

=cut
421
422sub prepare_workspace {
423
17
10944
        my $self = $_[0];
424
425        # Create a self-cleaning temporary directory
426
17
124
        my $tmp = tempdir(CLEANUP => 1);
427
428        # Normalise lib_dir to its final component so workspace paths
429        # are relative regardless of whether an absolute path was passed in
430
17
4635
        my $lib_basename = (File::Spec->splitdir($self->{lib_dir}))[-1];
431
432        # Derive the file's path relative to lib_dir for use by apply_mutant
433
17
34
        my $relative = $self->{file};
434
17
238
        $relative =~ s/^\Q$self->{lib_dir}\E\/?//;
435
436        # Copy the entire lib tree so all dependencies resolve in the workspace
437
17
176
        dircopy($self->{lib_dir}, File::Spec->catfile($tmp, $lib_basename)) or croak "dircopy failed: $!";
438
439        # Store normalised state under private keys — do NOT mutate lib_dir,
440        # which callers may inspect after this call expecting the original value.
441
16
25994
        $self->{_workspace}    = $tmp;
442
16
41
        $self->{_relative}     = $relative;
443
16
28
        $self->{_lib_basename} = $lib_basename;
444
445
16
45
        return $tmp;
446}
447
448 - 519
=head2 apply_mutant

Apply a single mutant's transform to the target file in the workspace.

    $mutator->apply_mutant($mutant);

=head3 Arguments

=over 4

=item * C<$mutant>

An L<App::Test::Generator::Mutant> object whose C<transform> closure
will be applied to the workspace copy of the target file.

=back

=head3 Returns

Nothing. Modifies the workspace copy of the target file in place.

=head3 Side effects

Overwrites the target file in the workspace with the mutated version.

=head3 API specification

=head4 input

    {
        self   => { type => OBJECT, isa => 'App::Test::Generator::Mutator' },
        mutant => { type => OBJECT, isa => 'App::Test::Generator::Mutant'  },
    }

=head4 output

    { type => UNDEF }

=head3 EXAMPLE

    $mutator->prepare_workspace();
    for my $m (@{$mutants}) {
        $mutator->apply_mutant($m);
        # workspace file is now mutated; run tests against it
    }

=head3 MESSAGES

=over 4

=item C<Workspace not prepared -- call prepare_workspace first>

C<apply_mutant> was called before C<prepare_workspace>.

=item C<Relative path not set -- call prepare_workspace first>

Internal: the relative-path field was not set by C<prepare_workspace>.

=item C<< Failed to parse TARGET >>

PPI could not parse the workspace copy of the target file.

=back

=head3 FORMAL SPECIFICATION

Pre:  C<self-E<gt>{_workspace}> is defined ∧ C<self-E<gt>{_relative}> is defined
      âˆ§ C<ref(mutant-E<gt>{transform}) eq 'CODE'>

Post: workspace copy of target file contains the mutated content

=cut
520
521sub apply_mutant {
522
14
1070
        my ($self, $mutant) = @_;
523
524        # Workspace must be prepared before applying any mutant
525        my $workspace = $self->{_workspace}
526
14
233
                or croak $ERR_WORKSPACE_NOT_SET;
527
528        my $relative  = $self->{_relative}
529
6
20
                or croak $ERR_RELATIVE_NOT_SET;
530
531        # Construct the full path to the file in the workspace
532        my $target = File::Spec->catfile(
533                $workspace,
534                $self->{_lib_basename},
535
6
42
                $relative,
536        );
537
538        # Parse the workspace copy and apply the mutation transform
539
6
59
        my $doc = PPI::Document->new($target) or croak "Failed to parse $target";
540
541
6
29809
        $mutant->transform->($doc);
542
543
6
185
        $doc->save($target);
544}
545
546 - 597
=head2 run_tests

Run the test suite against the current workspace and return whether all
tests passed.

    my $survived = $mutator->run_tests();

=head3 Arguments

None beyond C<$self>.

=head3 Returns

1 if all tests passed (mutant survived), 0 if any test failed (mutant
killed).

=head3 Side effects

Executes an external process running the test suite.

=head3 Notes

Uses C<prove> found on PATH. Sets C<PERL5LIB> to include the workspace
lib directory before running.

=head3 API specification

=head4 input

    {
        self => { type => OBJECT, isa => 'App::Test::Generator::Mutator' },
    }

=head4 output

    { type => SCALAR }

=head3 EXAMPLE

    my $survived = $mutator->run_tests();
    if($survived) {
        print "mutant survived\n";
    } else {
        print "mutant killed\n";
    }

=head3 FORMAL SPECIFICATION

Post: C<result ∈ {0, 1}>
      âˆ§ C<result == 1> ⟺ all tests in C<t/> passed against current C<lib/>

=cut
598
599sub run_tests {
600
6
1002
        my $self = $_[0];
601
602        # Derive prove from $^X so CPAN smokers that install to a non-PATH
603        # location still resolve the correct perl/prove pair.  Config{bin}
604        # is a reliable fallback; bare 'prove' is last resort only.
605
6
92
        my ($vol, $dir) = File::Spec->splitpath($^X);
606
6
48
        my $prove       = File::Spec->catpath($vol, $dir, 'prove');
607
6
54
        $prove          = File::Spec->catfile($Config{bin}, 'prove') unless -x $prove;
608
6
42
        $prove          = 'prove' unless -x $prove;
609
610
6
1043269
        return system($prove, '-l', 't') == 0;
611}
612
613# --------------------------------------------------
614# _dedup_mutants
615#
616# Purpose:    Remove duplicate and redundant mutants
617#             from a list, used in fast mutation mode
618#             to reduce the number of mutants to run.
619#
620# Entry:      $mutants - arrayref of Mutant objects.
621#
622# Exit:       Returns an arrayref of deduplicated
623#             Mutant objects.
624#
625# Side effects: None.
626#
627# Notes:      Deduplication key uses line, original,
628#             and description rather than the transform
629#             coderef, which is not stable as a string.
630# --------------------------------------------------
631sub _dedup_mutants {
632
38
2760
        my ($mutants) = @_;
633
38
45
        my @rc;
634        my %seen;
635
636
38
38
36
61
        for my $m (@{$mutants}) {
637                # Build a stable key from metadata — not from the coderef
638
194
196
                my $key = join '|',
639                        $m->line        // '',
640                        $m->original    // '',
641                        $m->description // '';
642
643
194
292
                next if $seen{$key}++;
644
187
157
                next if _is_redundant_mutation($m);
645
646
175
147
                push @rc, $m;
647        }
648
649
38
73
        return \@rc;
650}
651
652# --------------------------------------------------
653# _is_redundant_mutation
654#
655# Return true if a mutant is considered
656#     redundant and should be skipped in fast
657#     mutation mode.
658#
659# Entry:      $m - a Mutant object.
660#
661# Exit:       Returns 1 if redundant, 0 otherwise.
662#
663# Notes:      Checks for arithmetic no-ops, double
664#             negation inside conditionals, boolean
665#             literal flips, mutations inside comments,
666#             and equivalent numeric comparisons.
667#             Does not compare transform coderefs —
668#             they are not meaningful as strings.
669# --------------------------------------------------
670sub _is_redundant_mutation {
671
216
190
        my ($m) = @_;
672
673
216
183
        my $orig = $m->original // '';
674
675        # Arithmetic no-ops add nothing to mutation coverage
676
216
235
        return 1 if $orig =~ /\+\s*0$/;
677
209
223
        return 1 if $orig =~ /-\s*0$/;
678
679        # Double negation inside conditionals forces boolean context
680        # in Perl and is not a meaningful mutation
681
203
208
        if($m->context && $m->context eq 'conditional') {
682
58
66
                return 1 if $orig =~ /^\!\!/;
683        }
684
685        # Boolean literal flip on a standalone 1 or 0 is trivial
686
200
266
        return 1 if $orig =~ /^\s*(?:1|0)\s*$/;
687
688        # Mutations inside comments are unreachable code
689
189
167
        return 1 if $m->line_content && $m->line_content =~ /^\s*#/;
690
691
185
200
        return 0;
692}
693
694 - 781
=head1 COMMON PITFALLS

=over 4

=item Calling C<apply_mutant> before C<prepare_workspace>

C<apply_mutant> requires C<prepare_workspace> to have been called first. The
workspace holds the isolated copy of C<lib/> that receives mutations.

=item Passing an absolute path as C<lib_dir>

C<lib_dir> must be a B<relative> path (e.g. C<lib>). An absolute path causes
C<apply_mutant> to construct a doubled directory under the workspace and then
fail to find the target file.

=item Checking C<< $mutator->{workspace} >> after the refactor

Internal workspace state is stored in C<_workspace>, C<_relative>, and
C<_lib_basename> (note the underscore prefix). The original C<lib_dir> value
is never overwritten. Old code that reads C<< $mutator->{workspace} >> or
C<< $mutator->{relative} >> (without underscores) will not find these keys.

=item Forgetting that C<run_tests> drives C<prove> from C<$^X>

C<run_tests> resolves C<prove> from the same Perl binary used to run the script.
If you shell out to C<prove> directly in your own integration code, make sure
you are using the matching C<prove>.

=item C<generate_mutants> in list vs scalar context

C<generate_mutants> returns a flat list in list context and an arrayref in
scalar context.  Assign to an arrayref (C<my $m = $mutator-E<gt>generate_mutants()>)
to guarantee you always get a reference regardless of calling context.

=back

=head1 LIMITATIONS

=over 4

=item * Single strategy registry

The four built-in mutation strategies are hardcoded in C<new>. There is no
plugin mechanism for registering additional strategies without subclassing.
A future version should accept a C<strategies> arrayref argument.

=item * No parallelism

C<run_tests> is synchronous. For large test suites or large mutant sets,
wall-clock time scales linearly. The in-place mutation strategy also
serialises all mutants behind a single file lock.

=item * PPI re-parse per apply_mutant call

C<apply_mutant> re-parses the workspace copy of the target file for every
mutant. For very large single-file modules the PPI parse time may dominate.

=item * apply_mutant does not restore on abnormal exit

If the process is killed between the write and restore in
C<bin/test-generator-mutate>, the project file is left mutated.
A C<git restore lib/...> recovers it.

=back

=head1 SEE ALSO

=over 4

=item C<bin/test-generator-mutate>

=item L<Devel::Mutator>

=back

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 LICENCE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to the terms of GPL2.
If you use it,
please let me know.

=cut
782
7831;