File Coverage

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

linestmtbrancondsubtimecode
1package App::Test::Generator::Mutator;
2
3
10
10
10
147858
9
131
use strict;
4
10
10
10
15
9
193
use warnings;
5
10
10
10
23
14
177
use Carp qw(croak);
6
10
10
10
14
7
669
use Config;
7
10
10
10
1671
12794
272
use File::Copy qw(copy);
8
10
10
10
1892
16618
298
use File::Copy::Recursive qw(dircopy);
9
10
10
10
23
7
87
use File::Spec;
10
10
10
10
780
13697
170
use File::Temp qw(tempdir);
11
10
10
10
1502
462339
133
use PPI;
12
10
10
10
604
4815
197
use Readonly;
13
14
10
10
10
1396
10
690
use App::Test::Generator::Mutation::BooleanNegation;
15
10
10
10
1195
11
127
use App::Test::Generator::Mutation::ConditionalInversion;
16
10
10
10
1247
10
152
use App::Test::Generator::Mutation::NumericBoundary;
17
10
10
10
1279
11
5710
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.41';
32
33 - 106
=head1 NAME

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

=head1 VERSION

Version 0.41

=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
94
590130
        my ($class, %args) = @_;
110
111        # file is required and must exist on disk
112
94
223
        croak 'file required' unless defined $args{file};
113
90
504
        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
86
507
                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 - 168
=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

=head3 Returns

A list 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' },
    }

=cut
169
170sub generate_mutants {
171
51
4056
        my $self = $_[0];
172
173        # Parse the target file into a PPI document
174
51
217
        my $doc = PPI::Document->new($self->{file}) or croak "Unable to parse $self->{file}";
175
176        # Build set of lines excluded by ## MUTANT_SKIP_BEGIN / ## MUTANT_SKIP_END
177
51
275491
        my %skip_lines;
178
51
44
        my $in_skip  = 0;
179
51
42
        my $skip_start = 0;
180
51
44
        my $line_num = 0;
181
182
51
86
        for my $line (split /\n/, $doc->serialize()) {
183
805
24687
                $line_num++;
184
185                # Match only lines where the annotation is the entire content —
186                # prevents false positives in comments or POD that mention the tag
187
805
578
                if($line =~ /^\s*##\s*MUTANT_SKIP_BEGIN\s*$/) {
188
6
11
                        croak "$self->{file}: MUTANT_SKIP_BEGIN at line $line_num with no prior MUTANT_SKIP_END"
189                                if $in_skip;
190
5
4
                        $in_skip    = 1;
191
5
4
                        $skip_start = $line_num;
192                }
193
804
538
                $skip_lines{$line_num} = 1 if $in_skip;
194
195                # Match only lines where the annotation is the entire content —
196                # prevents false positives in comments or POD that mention the tag
197
804
611
                if($line =~ /^\s*##\s*MUTANT_SKIP_END\s*$/) {
198
4
16
                        croak "$self->{file}: MUTANT_SKIP_END at line $line_num with no matching MUTANT_SKIP_BEGIN"
199                                unless $in_skip;
200
2
2
                        $in_skip = 0;
201                }
202        }
203        # Unclosed MUTANT_SKIP_BEGIN is fatal
204
48
101
        croak "$self->{file}: MUTANT_SKIP_BEGIN at line $skip_start has no matching MUTANT_SKIP_END" if $in_skip;
205
206        # Store skip lines for use by the report generator
207
46
56
        $self->{skip_lines} = \%skip_lines;
208
209
46
39
        my @mutants;
210
211        # Run each registered mutation strategy against the document,
212        # excluding any candidates on skip-annotated lines. applies_to()
213        # is a cheap pre-filter -- skip the mutate() walk entirely for
214        # strategies that have nothing to match in this document.
215
46
46
33
55
        for my $mutation (@{$self->{mutations}}) {
216
184
361
                next unless $mutation->applies_to($doc);
217
147
626
222
521
                push @mutants, grep { !$skip_lines{$_->line} } $mutation->mutate($doc);
218        }
219
220        # In fast mode deduplicate and remove redundant mutants
221
46
121
        if($self->{mutation_level} eq $LEVEL_FAST) {
222
14
14
42
27
                return @{_dedup_mutants(\@mutants)};
223        }
224
225
32
228
        return @mutants;
226}
227
228 - 277
=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
278
279sub prepare_workspace {
280
13
949
        my $self = $_[0];
281
282        # Create a self-cleaning temporary directory
283
13
75
        my $tmp = tempdir(CLEANUP => 1);
284
285        # Normalise lib_dir to its final component so workspace paths
286        # are relative regardless of whether an absolute path was passed in
287
13
2664
        my $lib_basename = (File::Spec->splitdir($self->{lib_dir}))[-1];
288
289        # Derive the file's path relative to lib_dir for use by apply_mutant
290
13
15
        my $relative = $self->{file};
291
13
102
        $relative =~ s/^\Q$self->{lib_dir}\E\/?//;
292
293        # Copy the entire lib tree so all dependencies resolve in the workspace
294
13
107
        dircopy($self->{lib_dir}, File::Spec->catfile($tmp, $lib_basename)) or croak "dircopy failed: $!";
295
296
12
23445
        $self->{workspace} = $tmp;
297
12
29
        $self->{relative}  = $relative;
298
12
14
        $self->{lib_dir}   = $lib_basename;  # normalise for apply_mutant
299
300
12
24
        return $tmp;
301}
302
303 - 341
=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
342
343sub apply_mutant {
344
9
261
        my ($self, $mutant) = @_;
345
346        # Workspace must be prepared before applying any mutant
347        my $workspace = $self->{workspace}
348
9
83
                or croak 'Workspace not prepared — call prepare_workspace first';
349
350        my $relative  = $self->{relative}
351
5
17
                or croak 'Relative path not set — call prepare_workspace first';
352
353        # Construct the full path to the file in the workspace
354        my $target = File::Spec->catfile(
355                $workspace,
356                $self->{lib_dir},
357
5
35
                $relative,
358        );
359
360        # Parse the workspace copy and apply the mutation transform
361
5
57
        my $doc = PPI::Document->new($target) or croak "Failed to parse $target";
362
363
5
26687
        $mutant->transform->($doc);
364
365
5
126
        $doc->save($target);
366}
367
368 - 405
=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
406
407sub run_tests {
408
4
1229
        my $self = $_[0];
409
410        # Locate prove on PATH — fall back to bare 'prove' and let shell find it
411
4
45
        my $prove = File::Spec->catfile($Config{bin}, 'prove');
412
4
79
        $prove = 'prove' unless -x $prove;
413
414
4
8
        return system($prove, '-l', 't') == 0;
415}
416
417# --------------------------------------------------
418# _dedup_mutants
419#
420# Purpose:    Remove duplicate and redundant mutants
421#             from a list, used in fast mutation mode
422#             to reduce the number of mutants to run.
423#
424# Entry:      $mutants - arrayref of Mutant objects.
425#
426# Exit:       Returns an arrayref of deduplicated
427#             Mutant objects.
428#
429# Side effects: None.
430#
431# Notes:      Deduplication key uses line, original,
432#             and description rather than the transform
433#             coderef, which is not stable as a string.
434# --------------------------------------------------
435sub _dedup_mutants {
436
36
3120
        my ($mutants) = @_;
437
36
26
        my @rc;
438        my %seen;
439
440
36
36
32
37
        for my $m (@{$mutants}) {
441                # Build a stable key from metadata — not from the coderef
442
131
109
                my $key = join '|',
443                        $m->line        // '',
444                        $m->original    // '',
445                        $m->description // '';
446
447
131
167
                next if $seen{$key}++;
448
124
97
                next if _is_redundant_mutation($m);
449
450
112
94
                push @rc, $m;
451        }
452
453
36
81
        return \@rc;
454}
455
456# --------------------------------------------------
457# _is_redundant_mutation
458#
459# Return true if a mutant is considered
460#     redundant and should be skipped in fast
461#     mutation mode.
462#
463# Entry:      $m - a Mutant object.
464#
465# Exit:       Returns 1 if redundant, 0 otherwise.
466#
467# Notes:      Checks for arithmetic no-ops, double
468#             negation inside conditionals, boolean
469#             literal flips, mutations inside comments,
470#             and equivalent numeric comparisons.
471#             Does not compare transform coderefs —
472#             they are not meaningful as strings.
473# --------------------------------------------------
474sub _is_redundant_mutation {
475
153
158
        my ($m) = @_;
476
477
153
117
        my $orig = $m->original // '';
478
479        # Arithmetic no-ops add nothing to mutation coverage
480
153
163
        return 1 if $orig =~ /\+\s*0$/;
481
146
133
        return 1 if $orig =~ /-\s*0$/;
482
483        # Double negation inside conditionals forces boolean context
484        # in Perl and is not a meaningful mutation
485
140
117
        if($m->context && $m->context eq 'conditional') {
486
45
47
                return 1 if $orig =~ /^\!\!/;
487        }
488
489        # Boolean literal flip on a standalone 1 or 0 is trivial
490
137
213
        return 1 if $orig =~ /^\s*(?:1|0)\s*$/;
491
492        # Mutations inside comments are unreachable code
493
126
120
        return 1 if $m->line_content && $m->line_content =~ /^\s*#/;
494
495
122
118
        return 0;
496}
497
498 - 520
=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
521
5221;