File Coverage

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

linestmtbrancondsubtimecode
1package App::Test::Generator::Mutator;
2
3
6
6
6
6
218788
5
81
use strict;
4
6
6
6
6
9
5
138
use warnings;
5
6
6
6
6
10
5
109
use Carp qw(croak);
6
6
6
6
6
8
7
99
use Config;
7
6
6
6
6
1165
7814
194
use File::Copy qw(copy);
8
6
6
6
6
1232
10073
172
use File::Copy::Recursive qw(dircopy);
9
6
6
6
6
15
4
56
use File::Spec;
10
6
6
6
6
12
6
135
use File::Temp          qw(tempdir);
11
6
6
6
6
820
267463
82
use PPI;
12
6
6
6
6
596
4869
130
use Readonly;
13
14
6
6
6
6
866
6
86
use App::Test::Generator::Mutation::BooleanNegation;
15
6
6
6
6
817
9
77
use App::Test::Generator::Mutation::ConditionalInversion;
16
6
6
6
6
900
7
75
use App::Test::Generator::Mutation::NumericBoundary;
17
6
6
6
6
807
8
2642
use App::Test::Generator::Mutation::ReturnUndef;
18
19# --------------------------------------------------
20# Valid mutation level values
21# --------------------------------------------------
22Readonly my $LEVEL_FULL => 'full';
23Readonly my $LEVEL_FAST => 'fast';
24
25# --------------------------------------------------
26# Default values for optional constructor arguments
27# --------------------------------------------------
28Readonly my $DEFAULT_LIB_DIR        => 'lib';
29Readonly my $DEFAULT_MUTATION_LEVEL => $LEVEL_FULL;
30
31our $VERSION = '0.36';
32
33 - 106
=head1 NAME

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

=head1 VERSION

Version 0.36

=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',
    }

=cut
107
108sub new {
109
54
54
399957
        my ($class, %args) = @_;
110
111        # file is required and must exist on disk
112
54
100
149
        croak 'file required' unless defined $args{file};
113
52
100
291
        croak "file not found: $args{file}" unless -f $args{file};
114
115        return bless {
116                file           => $args{file},
117                lib_dir        => $args{lib_dir}        || $DEFAULT_LIB_DIR,
118
50
67
67
349
                mutation_level => $args{mutation_level} || $DEFAULT_MUTATION_LEVEL,
119
120                # Instantiate all registered mutation strategies
121                mutations => [
122                        App::Test::Generator::Mutation::BooleanNegation->new(),
123                        App::Test::Generator::Mutation::ReturnUndef->new(),
124                        App::Test::Generator::Mutation::NumericBoundary->new(),
125                        App::Test::Generator::Mutation::ConditionalInversion->new(),
126                ],
127        }, $class;
128}
129
130 - 161
=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();

=head3 Arguments

None beyond C<$self>.

=head3 Returns

A list of L<App::Test::Generator::Mutant> objects. In C<fast> mode,
redundant and duplicate mutants are removed before returning.

=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' },
    }

=cut
162
163sub generate_mutants {
164
30
30
3106
        my $self = $_[0];
165
166        # Parse the target file into a PPI document
167
30
50
143
        my $doc = PPI::Document->new($self->{file}) or croak "Unable to parse $self->{file}";
168
169
30
195185
        my @mutants;
170
171        # Run each registered mutation strategy against the document
172
30
30
34
49
        for my $mutation (@{ $self->{mutations} }) {
173
120
263
                push @mutants, $mutation->mutate($doc);
174        }
175
176        # In fast mode deduplicate and remove redundant mutants
177
30
100
84
        if($self->{mutation_level} eq $LEVEL_FAST) {
178
11
11
34
17
                return @{ _dedup_mutants(\@mutants) };
179        }
180
181
19
102
        return @mutants;
182}
183
184 - 233
=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} >> and C<< $self->{relative} >>.

=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,
    }

=cut
234
235sub prepare_workspace {
236
8
8
892
        my $self = $_[0];
237
238        # Create a self-cleaning temporary directory
239
8
52
        my $tmp = tempdir(CLEANUP => 1);
240
241        # Derive the file's path relative to lib_dir for use by apply_mutant
242
8
1862
        my $relative = $self->{file};
243
8
80
        $relative =~ s/^\Q$self->{lib_dir}\E\/?//;
244
245        # Copy the entire lib tree so all dependencies resolve in the workspace
246
8
50
76
        dircopy($self->{lib_dir}, File::Spec->catfile($tmp, $self->{lib_dir}))
247                or croak "dircopy failed: $!";
248
249
8
3727
        $self->{workspace} = $tmp;
250
8
14
        $self->{relative}  = $relative;
251
252
8
16
        return $tmp;
253}
254
255 - 293
=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 }

=cut
294
295sub apply_mutant {
296
6
6
744
        my ($self, $mutant) = @_;
297
298        # Workspace must be prepared before applying any mutant
299        my $workspace = $self->{workspace}
300
6
100
54
                or croak 'Workspace not prepared — call prepare_workspace first';
301
302        my $relative  = $self->{relative}
303
4
50
14
                or croak 'Relative path not set — call prepare_workspace first';
304
305        # Construct the full path to the file in the workspace
306        my $target = File::Spec->catfile(
307                $workspace,
308                $self->{lib_dir},
309
4
49
                $relative,
310        );
311
312        # Parse the workspace copy and apply the mutation transform
313
4
50
27
        my $doc = PPI::Document->new($target)
314                or croak "Failed to parse $target";
315
316
4
23442
        $mutant->{transform}->($doc);
317
318
4
101
        $doc->save($target);
319}
320
321 - 358
=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 }

=cut
359
360sub run_tests {
361
0
0
0
        my $self = $_[0];
362
363        # Locate prove on PATH — fall back to bare 'prove' and let shell find it
364
0
0
        my $prove = File::Spec->catfile($Config{bin}, 'prove');
365
0
0
0
        $prove = 'prove' unless -x $prove;
366
367
0
0
        return system($prove, '-l', 't') == 0;
368}
369
370# --------------------------------------------------
371# _dedup_mutants
372#
373# Purpose:    Remove duplicate and redundant mutants
374#             from a list, used in fast mutation mode
375#             to reduce the number of mutants to run.
376#
377# Entry:      $mutants - arrayref of Mutant objects.
378#
379# Exit:       Returns an arrayref of deduplicated
380#             Mutant objects.
381#
382# Side effects: None.
383#
384# Notes:      Deduplication key uses line, original,
385#             and description rather than the transform
386#             coderef, which is not stable as a string.
387# --------------------------------------------------
388sub _dedup_mutants {
389
28
28
117089
        my ($mutants) = @_;
390
28
24
        my @rc;
391        my %seen;
392
393
28
28
14
37
        for my $m (@{$mutants}) {
394                # Build a stable key from metadata — not from the coderef
395                my $key = join '|',
396                        $m->{line}        // '',
397                        $m->{original}    // '',
398
101
100
100
100
167
                        $m->{description} // '';
399
400
101
100
123
                next if $seen{$key}++;
401
95
100
72
                next if _is_redundant_mutation($m);
402
403
85
72
                push @rc, $m;
404        }
405
406
28
52
        return \@rc;
407}
408
409# --------------------------------------------------
410# _is_redundant_mutation
411#
412# Purpose:    Return true if a mutant is considered
413#             redundant and should be skipped in fast
414#             mutation mode.
415#
416# Entry:      $m - a Mutant hashref.
417#
418# Exit:       Returns 1 if redundant, 0 otherwise.
419#
420# Side effects: None.
421#
422# Notes:      Checks for arithmetic no-ops, double
423#             negation inside conditionals, boolean
424#             literal flips, mutations inside comments,
425#             and equivalent numeric comparisons.
426#             Does not compare transform coderefs —
427#             they are not meaningful as strings.
428# --------------------------------------------------
429sub _is_redundant_mutation {
430
114
114
24491
        my ($m) = @_;
431
432
114
100
105
        my $orig = $m->{original} // '';
433
434        # Arithmetic no-ops add nothing to mutation coverage
435
114
100
119
        return 1 if $orig =~ /\+\s*0$/;
436
109
100
93
        return 1 if $orig =~ /-\s*0$/;
437
438        # Double negation inside conditionals forces boolean context
439        # in Perl and is not a meaningful mutation
440
105
100
67
95
        if($m->{context} && $m->{context} eq 'conditional') {
441
2
50
6
                return 1 if $orig =~ /^\!\!/;
442        }
443
444        # Boolean literal flip on a standalone 1 or 0 is trivial
445
103
100
149
        return 1 if $orig =~ /^\s*(?:1|0)\s*$/;
446
447        # Mutations inside comments are unreachable code
448
94
100
100
85
        return 1 if $m->{line_content} && $m->{line_content} =~ /^\s*#/;
449
450
91
72
        return 0;
451}
452
453 - 478
=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> >>

Portions of this module's initial design and documentation were created
with the assistance of AI.

=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
479
4801;