File Coverage

File:bin/fuzz-harness-generator
Coverage:39.0%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2
3
7
7
7
7
15516
5
116
use strict;
4
7
7
7
7
8
7
140
use warnings;
5
7
7
7
7
1243
56418
11
use autodie qw(:all);
6
7
7
7
7
7
70180
18
205
use App::Test::Generator;
8
7
7
7
7
16
5
80
use File::Spec;
9
7
7
7
7
12
6
228
use File::Temp;
10
7
7
7
7
2598
31303
15
use Getopt::Long qw(GetOptions);
11
7
7
7
7
2463
124739
522
use Pod::Usage;
12
7
7
7
7
24
5
5794
use YAML::XS qw(LoadFile);
13
14# Derive prove from $^X so we always use the same perl installation that
15# invoked this script, even when $PATH resolves to a different system perl.
16
7
526880
my ($prove_vol, $prove_dir) = (File::Spec->splitpath($^X))[0, 1];
17
7
67
my $prove = File::Spec->catpath($prove_vol, $prove_dir, 'prove');
18
19 - 97
=head1 NAME

fuzz-harness-generator - Generate fuzzing + corpus-based test harnesses from test schemas

=head1 SYNOPSIS

  fuzz-harness-generator [-r] [-o output_file] input.yaml
  fuzz-harness-generator --dry-run input.yaml
  fuzz-harness-generator --replay-corpus schemas/corpus/ -o t/fuzz_replay.t
  fuzz-harness-generator --replay-corpus schemas/corpus/translate.json -o t/fuzz_replay.t

=head1 DESCRIPTION

This tool generates a test file that fuzzes and validates a target module's function or method,
using both randomized fuzz cases and a static corpus cases (Perl or YAML).

It can also generate regression test files from corpus JSON files previously
written by C<extract-schemas --fuzz>, using C<--replay-corpus>.

A starter C<input.yaml> can be created using C<extract-schemas> which is also in this package.

=head1 OPTIONS

=over 4

=item B<--help>

Show this help.

=item B<--input>

The input configuration file

=item B<--output>

The (optional) output file.

=item B<--dry-run>

Validate the input configuration and schema extraction without writing any output files or running tests.

=item B<--run>

Call C<prove> on the output file.

C<fuzz-harness-generator -r t/conf/data_text_append.conf> will, therefore, dynamically create and run tests on the C<append> method of L<Data::Text>

=item B<--replay-corpus> PATH

Instead of generating a fuzz harness, generate a regression test file from
one or more corpus JSON files previously written by C<extract-schemas --fuzz>.

PATH may be either:

=over 4

=item * A single corpus file, e.g. C<schemas/corpus/translate.json>

=item * A directory, e.g. C<schemas/corpus/> — all C<*.json> files in that
directory will be included

=back

The generated test file contains one failing test per bug recorded in the
corpus. Each test calls the target method with the exact input that previously
caused a crash and expects it B<not> to die. Tests will be red until the
underlying bug is fixed, at which point they go green and stay green —
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
98
99
7
42
my $infile;
100my $outfile;
101
7
0
my $help;
102
7
0
my $run;
103
7
0
my $verbose;
104
7
0
my $version;
105
7
0
my $dry_run;
106
7
0
my $replay_corpus;
107
108
7
30
Getopt::Long::Configure('bundling');
109
110
7
50
168
GetOptions(
111        'help|h'          => \$help,
112        'input|i=s'       => \$infile,
113        'dry-run|n'       => \$dry_run,
114        'output|o=s'      => \$outfile,
115        'run|r'           => \$run,
116        'verbose|v'       => \$verbose,
117        'version|V'       => \$version,
118        'replay-corpus|R=s' => \$replay_corpus,
119) or pod2usage(2);
120
121
7
100
3906
pod2usage(-exitval => 0, -verbose => 1) if($help);
122
123
5
100
14
if($version) {
124
1
6
        print $App::Test::Generator::VERSION, "\n";
125
1
48
        exit 0;
126}
127
128# ---------------------------------------------------------------------------
129# --replay-corpus mode: generate a regression .t from corpus bug entries
130# ---------------------------------------------------------------------------
131
132
4
50
6
if($replay_corpus) {
133
0
0
0
        pod2usage('--replay-corpus cannot be combined with --dry-run') if $dry_run;
134
0
0
0
        pod2usage('--replay-corpus cannot be combined with --input')   if $infile;
135
136
0
0
        my @corpus_files = _collect_corpus_files($replay_corpus);
137
0
0
0
        die "No corpus JSON files found at: $replay_corpus\n" unless @corpus_files;
138
139
0
0
        my $tap = _generate_replay_tap(@corpus_files);
140
141
0
0
0
        if($outfile) {
142
0
0
0
                open(my $fh, '>', $outfile)
143                        or die "Cannot write to $outfile: $!";
144
0
0
                print $fh $tap;
145
0
0
                close $fh;
146
0
0
                chmod 0755, $outfile;
147
0
0
                print "Replay test written to: $outfile\n";
148
0
0
0
                if($run) {
149
0
0
                        exit system($prove, '-l', $outfile) >> 8;
150                }
151        } else {
152
0
0
                print $tap;
153        }
154
0
0
        exit 0;
155}
156
157
4
50
33
18
if($infile && @ARGV) {
158
0
0
        pod2usage('Specify input file either as argument or via --input, not both');
159}
160
161
4
50
8
if($infile) {
162
4
4
6
15
        my $schema = eval { LoadFile($infile) };
163
4
100
445
        if($@) {
164
1
94
                die "Cannot parse '$infile' as YAML: $@";
165        }
166
3
50
10
        unless(ref($schema) eq 'HASH') {
167
0
0
                die "Input file '$infile' does not contain a YAML hash";
168        }
169
3
50
15
        unless($schema->{function}) {
170
0
0
                die "Input file '$infile' is missing required 'function' key";
171        }
172}
173
174
3
50
33
9
$infile ||= shift @ARGV or pod2usage('No config file given');
175
176
3
50
67
9
if($dry_run && $run) {
177
0
0
        pod2usage('--dry-run cannot be used with --run');
178}
179
180
3
100
100
8
if($dry_run && $outfile) {
181
1
50
        warn '--dry-run specified; --output will be ignored';
182}
183
184
3
50
6
if($verbose) {
185
0
0
        $ENV{'TEST_VERBOSE'} = 1;
186}
187
188
3
50
33
7
if($run && !$outfile) {
189
0
0
        my ($fh, $tmp) = File::Temp::tempfile();
190
0
0
        close $fh;
191
192
0
0
        App::Test::Generator->generate($infile, $tmp);
193
194
0
0
        exit system($prove, '-l', $tmp) >> 8;
195}
196
197
3
100
50
25
13
if($dry_run) {
198
2
8
        my ($fh, $tmp) = File::Temp::tempfile();
199
2
568
        close $fh;
200
201        eval {
202
2
24
                App::Test::Generator->generate($infile, $tmp);
203
2
193
                1;
204
2
50
951
        } or do {
205
0
0
                die "Dry-run failed for $infile: $@";
206        };
207
208
2
7
        unlink $tmp;
209
2
538
        print "Dry-run OK: $infile parsed and validated successfully\n";
210
2
109
        exit 0;
211} elsif($outfile && -e $outfile && !$run) {
212
0
0
        warn "Overwriting existing file: $outfile";
213}
214
215
1
9
App::Test::Generator->generate($infile, $outfile);
216
217
1
50
82
if($outfile) {
218
1
50
3
        chmod 0755, $outfile if($outfile =~ /\.(pl|cgi)$/);
219
1
50
2
        if($run) {
220                # Use list form to avoid shell interpolation of $outfile
221
0
0
                system($prove, '-l', $outfile);
222        }
223}
224
225
1
51
exit 0;
226
227# ---------------------------------------------------------------------------
228# Helpers for --replay-corpus
229# ---------------------------------------------------------------------------
230
231# --------------------------------------------------
232# _collect_corpus_files
233#
234# Collect the list of corpus JSON files
235#     to process for --replay-corpus mode.
236#     Accepts either a single file path or
237#     a directory, returning all *.json files
238#     found in the directory case.
239#
240# Entry:      $path - filesystem path to either a
241#                     single .json file or a directory
242#                     containing .json files.
243#
244# Exit:       Returns a sorted list of file paths.
245#             Returns an empty list if the path does
246#             not exist or contains no .json files.
247#
248# Notes:      Directory globbing matches only *.json
249#             files at the top level of the directory;
250#             subdirectories are not recursed into.
251# --------------------------------------------------
252sub _collect_corpus_files {
253
0
0
        my ($path) = @_;
254
255
0
0
0
        if(-f $path) {
256
0
                return ($path);
257        } elsif(-d $path) {
258
0
                my @files = glob(File::Spec->catfile($path, '*.json'));
259
0
                return sort @files;
260        }
261
262
0
        return ();
263}
264
265# --------------------------------------------------
266# _generate_replay_tap
267#
268# Purpose:    Read one or more corpus JSON files and
269#             produce a complete .t file as a string.
270#             Each bug entry in the corpus becomes
271#             one lives_ok test that calls the target
272#             method with the exact input that
273#             previously caused a crash, asserting
274#             that it no longer dies.
275#
276# Entry:      @corpus_files - list of paths to corpus
277#                             JSON files as returned
278#                             by _collect_corpus_files.
279#
280# Exit:       Returns the complete .t file content as
281#             a string. Never returns undef.
282#             Returns a skip_all plan if no bugs are
283#             found across all corpus files.
284#
285# Side effects: Reads corpus JSON files from disk.
286#               Attempts to load JSON::MaybeXS or
287#               JSON via block eval.
288#
289# Notes:      Corpus files that cannot be parsed are
290#             skipped with a warning rather than
291#             aborting the entire run.
292#             Clean corpus entries (those without
293#             recorded bugs) are silently ignored —
294#             only entries with a 'bugs' array are
295#             processed.
296#             The module name for each test is
297#             inferred from the YAML schema file
298#             alongside the corpus file via
299#             _infer_module_from_schema. Falls back
300#             to 'UNKNOWN::Module' if not found.
301# --------------------------------------------------
302sub _generate_replay_tap {
303
0
0
        my (@corpus_files) = @_;
304
305        # Prefer JSON::MaybeXS for correctness; fall back to JSON
306
0
        my $json_module;
307
0
        for my $mod (qw(JSON::MaybeXS JSON)) {
308
0
0
0
0
0
                eval { require $mod; 1 } and $json_module = $mod and last;
309        }
310
0
0
        die "No JSON module available; install JSON or JSON::MaybeXS\n"
311                unless $json_module;
312
313        # Collect all bugs across all corpus files into a flat list
314
0
        my @tests;
315
316
0
        for my $file (@corpus_files) {
317
0
0
                open(my $fh, '<', $file)
318                        or die "Cannot read $file: $!";
319
0
                my $data = eval {
320
0
0
0
                        $json_module->new->decode(do { local $/; <$fh> })
321                };
322
0
                close $fh;
323
324
0
0
                if($@) {
325
0
                        warn "Skipping $file: could not parse JSON: $@\n";
326
0
                        next;
327                }
328
329
0
0
                my $bugs = $data->{'bugs'} // [];
330
0
0
0
                next unless @{$bugs};
331
332                # Derive method name from filename: translate.json -> translate
333
0
                my (undef, undef, $fname) = File::Spec->splitpath($file);
334
0
                (my $method = $fname) =~ s/\.json$//;
335
336                # Look up the module name from the companion schema file;
337                # fall back to a placeholder if the schema cannot be found
338
0
0
                my $module = _infer_module_from_schema($file, $method)
339                        // 'UNKNOWN::Module';
340
341
0
0
                for my $bug (@{$bugs}) {
342                        push @tests, {
343                                module => $module,
344                                method => $method,
345                                input  => $bug->{'input'},
346
0
                                error  => $bug->{'error'},
347                                file   => $file,
348                        };
349                }
350        }
351
352        # Build the .t header — include Test::Exception up front since
353        # lives_ok is always needed when there are tests to emit
354
0
        my $t = <<'HEADER';
355#!/usr/bin/env perl
356# Auto-generated by fuzz-harness-generator --replay-corpus
357# DO NOT EDIT - regenerate from corpus files instead
358use strict;
359use warnings;
360use Test::More;
361use Test::Exception;
362HEADER
363
364
0
        my $test_count = scalar @tests;
365
366
0
0
        if($test_count == 0) {
367
0
                $t .= "\nplan skip_all => 'No bugs recorded in corpus files';\n";
368
0
                return $t;
369        }
370
371        # Emit one use statement per unique module (excluding the placeholder)
372
0
0
        my %modules = map { $_->{'module'} => 1 } @tests;
373
0
        for my $mod (sort keys %modules) {
374
0
0
                next if $mod eq 'UNKNOWN::Module';
375
0
                $t .= "use $mod;\n";
376        }
377
378
0
        $t .= "\nplan tests => $test_count;\n\n";
379
380
0
        for my $i (0 .. $#tests) {
381
0
                my $test  = $tests[$i];
382
0
                my $n     = $i + 1;
383
0
                my $input = _format_input($test->{'input'});
384
0
                my $label = "$test->{'method'} does not die on input from $test->{'file'}";
385
386                # Flatten and escape the original error for use as a comment
387
0
0
                (my $orig_error = $test->{'error'} // '') =~ s/\n/ /g;
388
0
                $orig_error =~ s/'/\\'/g;
389
390
0
                $t .= "# Corpus bug: $orig_error\n";
391
0
                $t .= "lives_ok { $test->{'module'}\->$test->{'method'}($input) }\n";
392
0
                $t .= "    '$label';\n\n";
393        }
394
395
0
        return $t;
396}
397
398# --------------------------------------------------
399# _format_input
400#
401# Purpose:    Format a scalar input value as a Perl
402#             literal string suitable for embedding
403#             directly in generated test source code.
404#
405# Entry:      $input - the input value to format.
406#                      May be undef, a numeric string,
407#                      or an arbitrary string.
408#
409# Exit:       Returns a Perl literal string:
410#               'undef'     if $input is undef
411#               bare number if $input looks numeric
412#               single-quoted string otherwise, with
413#               backslashes and single quotes escaped.
414#
415# Side effects: None.
416#
417# Notes:      Only scalar inputs are handled — corpus
418#             entries with arrayref or hashref inputs
419#             are not currently supported and will be
420#             formatted as a single-quoted string of
421#             the stringified reference, which will
422#             not reproduce the original input.
423# --------------------------------------------------
424sub _format_input {
425
0
0
        my ($input) = @_;
426
427
0
0
        return 'undef' unless defined $input;
428
429        # Emit bare numeric literals without quoting
430
0
0
        return $input if $input =~ /^-?(?:\d+\.?\d*|\.\d+)$/;
431
432        # Escape backslashes first, then single quotes, to avoid
433        # double-escaping when both appear in the same string
434
0
        (my $escaped = $input) =~ s/\\/\\\\/g;
435
0
        $escaped =~ s/'/\\'/g;
436
437
0
        return "'$escaped'";
438}
439
440# --------------------------------------------------
441# _infer_module_from_schema
442#
443# Purpose:    Attempt to determine the Perl module
444#             name for a given corpus method by
445#             locating and reading the companion YAML
446#             schema file that sits alongside the
447#             corpus directory.
448#
449# Entry:      $corpus_file - path to the corpus JSON
450#                            file, e.g.
451#                            schemas/corpus/translate.json
452#             $method      - the method name derived
453#                            from the corpus filename,
454#                            e.g. 'translate'
455#
456# Exit:       Returns the module name string if found,
457#             or undef if no companion schema file
458#             exists or the schema contains no
459#             'module:' line.
460#
461# Side effects: Reads schema files from disk.
462#
463# Notes:      The corpus is expected to live one
464#             directory below the schemas directory,
465#             e.g. schemas/corpus/ alongside
466#             schemas/translate.yaml. This function
467#             walks up one level from the corpus
468#             directory to find the schema.
469#             Both .yaml and .yml extensions are
470#             tried, in that order.
471# --------------------------------------------------
472sub _infer_module_from_schema {
473
0
0
        my ($corpus_file, $method) = @_;
474
475
0
        my (undef, $corpus_dir) = File::Spec->splitpath($corpus_file);
476
477        # Walk up one directory from corpus/ to reach the schemas/ dir
478
0
        my $schema_dir = File::Spec->catdir($corpus_dir, File::Spec->updir());
479
480
0
        for my $ext (qw(yaml yml)) {
481
0
                my $schema_file = File::Spec->catfile($schema_dir, "$method.$ext");
482
0
0
                next unless -f $schema_file;
483
484
0
0
                open(my $fh, '<', $schema_file) or next;
485
0
                while(<$fh>) {
486
0
0
                        if(/^module:\s*(\S+)/) {
487
0
                                close $fh;
488
0
                                return $1;
489                        }
490                }
491
0
                close $fh;
492        }
493
494
0
        return undef;
495}
496