view release on metacpan or  search on metacpan

bin/fuzz-harness-generator  view on Meta::CPAN

			next;
		}

		my $bugs = $data->{'bugs'} // [];
		next unless @{$bugs};

		# Derive method name from filename: translate.json -> translate
		my (undef, undef, $fname) = File::Spec->splitpath($file);
		(my $method = $fname) =~ s/\.json$//;

		# Look up the module name from the companion schema file;
		# fall back to a placeholder if the schema cannot be found
		my $module = _infer_module_from_schema($file, $method)
			// 'UNKNOWN::Module';

		for my $bug (@{$bugs}) {
			push @tests, {
				module => $module,
				method => $method,
				input  => $bug->{'input'},
				error  => $bug->{'error'},
				file   => $file,
			};
		}
	}

	# Build the .t header — include Test::Exception up front since
	# lives_ok is always needed when there are tests to emit
	my $t = <<'HEADER';
#!/usr/bin/env perl
# Auto-generated by fuzz-harness-generator --replay-corpus
# DO NOT EDIT - regenerate from corpus files instead
use strict;
use warnings;
use Test::More;
use Test::Exception;
HEADER

	my $test_count = scalar @tests;

	if($test_count == 0) {
		$t .= "\nplan skip_all => 'No bugs recorded in corpus files';\n";
		return $t;
	}

	# Emit one use statement per unique module (excluding the placeholder)
	my %modules = map { $_->{'module'} => 1 } @tests;
	for my $mod (sort keys %modules) {
		next if $mod eq 'UNKNOWN::Module';
		$t .= "use $mod;\n";
	}

	$t .= "\nplan tests => $test_count;\n\n";

	for my $i (0 .. $#tests) {
		my $test  = $tests[$i];
		my $n     = $i + 1;
		my $input = _format_input($test->{'input'});
		my $label = "$test->{'method'} does not die on input from $test->{'file'}";

		# Flatten and escape the original error for use as a comment
		(my $orig_error = $test->{'error'} // '') =~ s/\n/ /g;
		$orig_error =~ s/'/\\'/g;

		$t .= "# Corpus bug: $orig_error\n";
		$t .= "lives_ok { $test->{'module'}\->$test->{'method'}($input) }\n";
		$t .= "    '$label';\n\n";
	}

	return $t;
}

# --------------------------------------------------
# _format_input
#
# Purpose:    Format a scalar input value as a Perl
#             literal string suitable for embedding
#             directly in generated test source code.
#
# Entry:      $input - the input value to format.
#                      May be undef, a numeric string,
#                      or an arbitrary string.
#
# Exit:       Returns a Perl literal string:
#               'undef'     if $input is undef
#               bare number if $input looks numeric
#               single-quoted string otherwise, with
#               backslashes and single quotes escaped.
#
# Side effects: None.
#
# Notes:      Only scalar inputs are handled — corpus
#             entries with arrayref or hashref inputs
#             are not currently supported and will be
#             formatted as a single-quoted string of
#             the stringified reference, which will
#             not reproduce the original input.
# --------------------------------------------------
sub _format_input {
	my ($input) = @_;

	return 'undef' unless defined $input;

	# Emit bare numeric literals without quoting
	return $input if $input =~ /^-?(?:\d+\.?\d*|\.\d+)$/;

	# Escape backslashes first, then single quotes, to avoid
	# double-escaping when both appear in the same string
	(my $escaped = $input) =~ s/\\/\\\\/g;
	$escaped =~ s/'/\\'/g;

	return "'$escaped'";
}

# --------------------------------------------------
# _infer_module_from_schema
#
# Purpose:    Attempt to determine the Perl module
#             name for a given corpus method by
#             locating and reading the companion YAML
#             schema file that sits alongside the
#             corpus directory.
#
# Entry:      $corpus_file - path to the corpus JSON
#                            file, e.g.
#                            schemas/corpus/translate.json
#             $method      - the method name derived
#                            from the corpus filename,
#                            e.g. 'translate'
#
# Exit:       Returns the module name string if found,
#             or undef if no companion schema file
#             exists or the schema contains no
#             'module:' line.
#
# Side effects: Reads schema files from disk.
#
# Notes:      The corpus is expected to live one
#             directory below the schemas directory,
#             e.g. schemas/corpus/ alongside
#             schemas/translate.yaml. This function
#             walks up one level from the corpus
#             directory to find the schema.
#             Both .yaml and .yml extensions are
#             tried, in that order.
# --------------------------------------------------
sub _infer_module_from_schema {
	my ($corpus_file, $method) = @_;

	my (undef, $corpus_dir) = File::Spec->splitpath($corpus_file);

	# Walk up one directory from corpus/ to reach the schemas/ dir
	my $schema_dir = File::Spec->catdir($corpus_dir, File::Spec->updir());

	for my $ext (qw(yaml yml)) {
		my $schema_file = File::Spec->catfile($schema_dir, "$method.$ext");
		next unless -f $schema_file;

		open(my $fh, '<', $schema_file) or next;
		while(<$fh>) {
			if(/^module:\s*(\S+)/) {
				close $fh;
				return $1;
			}
		}
		close $fh;
	}

	return undef;
}

__END__