view release on metacpan or  search on metacpan

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

acting as permanent regression tests.

Only corpus entries with recorded bugs are included. Clean corpus entries
(inputs that did not cause a bug) are ignored.

=item B<--version>

Prints the version of L<App::Test::Generator>

=back

=cut

my $infile;
my $outfile;
my $help;
my $run;
my $verbose;
my $version;
my $dry_run;
my $replay_corpus;

Getopt::Long::Configure('bundling');

GetOptions(
	'help|h'          => \$help,
	'input|i=s'       => \$infile,
	'dry-run|n'       => \$dry_run,
	'output|o=s'      => \$outfile,
	'run|r'           => \$run,
	'verbose|v'       => \$verbose,
	'version|V'       => \$version,
	'replay-corpus|R=s' => \$replay_corpus,
) or pod2usage(2);

pod2usage(-exitval => 0, -verbose => 1) if($help);

if($version) {
	print $App::Test::Generator::VERSION, "\n";
	exit 0;
}

# ---------------------------------------------------------------------------
# --replay-corpus mode: generate a regression .t from corpus bug entries
# ---------------------------------------------------------------------------

if($replay_corpus) {
	pod2usage('--replay-corpus cannot be combined with --dry-run') if $dry_run;
	pod2usage('--replay-corpus cannot be combined with --input')   if $infile;

	my @corpus_files = _collect_corpus_files($replay_corpus);
	die "No corpus JSON files found at: $replay_corpus\n" unless @corpus_files;

	my $tap = _generate_replay_tap(@corpus_files);

	if($outfile) {
		open(my $fh, '>', $outfile)
			or die "Cannot write to $outfile: $!";
		print $fh $tap;
		close $fh;
		chmod 0755, $outfile;
		print "Replay test written to: $outfile\n";
		if($run) {
			exit system('prove', '-l', $outfile) >> 8;
		}
	} else {
		print $tap;
	}
	exit 0;
}

if($infile && @ARGV) {
	pod2usage('Specify input file either as argument or via --input, not both');
}

if($infile) {
	my $schema = eval { LoadFile($infile) };
	if($@) {
		die "Cannot parse '$infile' as YAML: $@";
	}
	unless(ref($schema) eq 'HASH') {
		die "Input file '$infile' does not contain a YAML hash";
	}
	unless($schema->{function}) {
		die "Input file '$infile' is missing required 'function' key";
	}
}

$infile ||= shift @ARGV or pod2usage('No config file given');

if($dry_run && $run) {
	pod2usage('--dry-run cannot be used with --run');
}

if($dry_run && $outfile) {
	warn '--dry-run specified; --output will be ignored';
}

if($verbose) {
	$ENV{'TEST_VERBOSE'} = 1;
}

if($run && !$outfile) {
	my ($fh, $tmp) = File::Temp::tempfile();
	close $fh;

	App::Test::Generator->generate($infile, $tmp);

	exit system('prove', '-l', $tmp) >> 8;
}

if($dry_run) {
	my ($fh, $tmp) = File::Temp::tempfile();
	close $fh;

	eval {
		App::Test::Generator->generate($infile, $tmp);
		1;
	} or do {
		die "Dry-run failed for $infile: $@";
	};

	unlink $tmp;
	print "Dry-run OK: $infile parsed and validated successfully\n";
	exit 0;
} elsif($outfile && -e $outfile && !$run) {
	warn "Overwriting existing file: $outfile";
}

App::Test::Generator->generate($infile, $outfile);

if($outfile) {
	chmod 0755, $outfile if($outfile =~ /\.(pl|cgi)$/);
	if($run) {
		# Use list form to avoid shell interpolation of $outfile
		system('prove', '-l', $outfile);
	}
}

exit 0;

# ---------------------------------------------------------------------------
# Helpers for --replay-corpus
# ---------------------------------------------------------------------------

# --------------------------------------------------
# _collect_corpus_files
#
# Collect the list of corpus JSON files
#     to process for --replay-corpus mode.
#     Accepts either a single file path or
#     a directory, returning all *.json files
#     found in the directory case.
#
# Entry:      $path - filesystem path to either a
#                     single .json file or a directory
#                     containing .json files.
#
# Exit:       Returns a sorted list of file paths.
#             Returns an empty list if the path does
#             not exist or contains no .json files.
#
# Side effects: None.
#
# Notes:      Directory globbing matches only *.json
#             files at the top level of the directory;
#             subdirectories are not recursed into.
# --------------------------------------------------
sub _collect_corpus_files {
	my ($path) = @_;

	if(-f $path) {
		return ($path);
	} elsif(-d $path) {
		my @files = glob(File::Spec->catfile($path, '*.json'));
		return sort @files;
	}

	return ();
}

# --------------------------------------------------
# _generate_replay_tap
#
# Purpose:    Read one or more corpus JSON files and
#             produce a complete .t file as a string.
#             Each bug entry in the corpus becomes
#             one lives_ok test that calls the target
#             method with the exact input that
#             previously caused a crash, asserting
#             that it no longer dies.
#
# Entry:      @corpus_files - list of paths to corpus