view release on metacpan or  search on metacpan

lib/App/Test/Generator/Mutation/NumericBoundary.pm  view on Meta::CPAN

=cut

sub mutate {
	my ($self, $doc) = @_;

	# Find all operator tokens in the document
	my $ops = $doc->find('PPI::Token::Operator') || [];
	my @mutants;

	for my $op (@{$ops}) {
		my $original = $op->content();

		# Skip readline operators — < immediately followed by
		# a symbol token is <$fh> not a numeric comparison
		my $next_sib = $op->next_sibling();
		next if $next_sib && $next_sib->isa('PPI::Token::Symbol');

		# Only process comparison operators that have defined flips
		next unless exists $FLIP{$original};

		# Only mutate operators that are direct children of
		# a condition or expression, not list arguments
		my $parent = $op->parent;
		next unless $parent->isa('PPI::Statement')
			|| $parent->isa('PPI::Structure::Condition')
			|| $parent->isa('PPI::Structure::Block');

		# Capture location so the transform closure targets the
		# exact operator rather than the first match on that line
		my $line = $op->location->[0];
		my $col  = $op->location->[1];

		# Generate one mutant per flip of this operator
		for my $change (@{ $FLIP{$original} }) {

			# Build a unique id from location and the specific flip
			# so multiple operators on the same line don't collide
			my $id = "NUM_BOUNDARY_${line}_${col}_${change}";

			my $mutant = eval {
				App::Test::Generator::Mutant->new(
					id          => $id,
					group       => "NUM_BOUNDARY:$line",
					description => "Numeric boundary flip $original to $change",
					original    => $original,
					line        => $line,
					type        => 'comparison',

					# The transform closure captures line, col, original
					# and change so it targets precisely the right operator
					# in the document copy it receives at test time
					transform => sub {
						my $doc  = $_[0];
						my $ops  = $doc->find('PPI::Token::Operator') || [];

						for my $op (@{$ops}) {
							next unless $op->line_number   == $line;
							next unless $op->column_number == $col;
							next unless $op->content       eq $original;

							# Safety check — do not mutate if this looks like
							# a readline operator (<$fh>) rather than a numeric
							# comparison. A readline < is immediately followed
							# by a symbol token starting with $
							my $next_sib = $op->next_sibling;
							if($next_sib && $next_sib->isa('PPI::Token::Symbol')) {
								last;
							}

							$op->set_content($change);
							last;
						}
					},
				);
			};

			# If Mutant construction fails, report clearly rather than
			# silently dropping the mutant from the results
			if($@ || !$mutant) {
				warn "Failed to construct mutant $id: $@\n" if $@;
				next;
			}

			push @mutants, $mutant;
		}
	}

	return @mutants;
}

1;