File Coverage

File:bin/extract-schemas
Coverage:72.7%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2
3
9
9
9
9
18471
9
142
use strict;
4
9
9
9
9
14
6
228
use warnings;
5
6
9
742169
$| = 1;  # unbuffered stdout so messages appear in execution order
7
8
9
9
9
9
2097
29642
278
use Data::Dumper;
9
9
9
9
9
21
9
276
use File::Path qw(make_path);
10
9
9
9
9
15
8
60
use File::Spec;
11
9
9
9
9
2777
41094
23
use Getopt::Long;
12
9
9
9
9
2080
4301
242
use FindBin;
13
9
9
9
9
1540
2581
28
use lib "$FindBin::Bin/../lib";
14
9
9
9
9
2353
234959
504
use Pod::Usage;
15
16
9
9
9
9
6178
21
17666
use App::Test::Generator::SchemaExtractor;
17
18 - 131
=head1 NAME

extract-schemas - Extract test schemas from Perl modules

=head1 SYNOPSIS

    extract-schemas [options] <module.pm>

    Options:
      --output-dir DIR    Output directory for schema files (default: schemas/)
      --strict-pod=off|warn|fatal
      --function NAME     Only extract and test this one routine (useful for
                          debugging a single failure in t/self-fuzz.t)
      --verbose           Show detailed analysis
      --version           Show the version of App::Test::Generator::SchemaExtractor
      --fuzz              Run coverage-guided fuzzing on extracted schemas
      --fuzz-iters N      Iterations per method when fuzzing (default: 100)
                          (no short form, to avoid conflict with --fuzz/-f)
      --fuzz-all          Fuzz all methods, including those with no input schema
      --corpus-dir DIR    Directory to persist fuzz corpora (default: schemas/corpus/)
      --minimize-corpus   After fuzzing, trim each corpus to the minimum subset
                          that still covers all discovered branches (greedy set-cover).
                          Keeps the corpus file small across many CI runs.
      --help              Show this help message
      --man               Show full documentation

    Examples:
      extract-schemas lib/MyModule.pm
      extract-schemas --output-dir my_schemas --verbose lib/MyModule.pm
      extract-schemas --function greet lib/MyModule.pm
      extract-schemas --fuzz lib/MyModule.pm
      extract-schemas --fuzz --function greet lib/MyModule.pm
      extract-schemas --fuzz --fuzz-iters 300 --corpus-dir t/corpus lib/MyModule.pm
      extract-schemas --fuzz --fuzz-all lib/MyModule.pm
      extract-schemas --fuzz --minimize-corpus lib/MyModule.pm

=head1 QUICK START

Run C<extract-schemas --strict-pod=warn -v --fuzz lib/MyModule.pm> to analyse your module and
automatically probe each method with hundreds of fuzzed inputs,
looking for
crashes caused by inputs that should be valid.
Anything suspicious is saved to C<schemas/corpus/>.

If genuine bugs are found,
run C<fuzz-harness-generator --replay-corpus schemas/corpus/ -o t/fuzz_replay.t>
to turn them into regression tests that will fail until you fix the underlying code and pass forever after.
Run C<extract-schemas --fuzz> regularly - each
run builds on the last, probing deeper into your code each time.

Otherwise, for each of the functions in MyModule.pm,
C<fuzz-harness-generator -r schemas/function.yml>

=head1 DESCRIPTION

This tool analyzes a Perl module and generates YAML schema files for each
method, suitable for use with L<App::Test::Generator>
using the C<fuzz-harness-generator> program which will create the C<.t> file to run through C<prove>.

The extractor uses three sources of information:

=over 4

=item 1. POD Documentation

Parses parameter descriptions from POD to extract types and constraints.

=item 2. Code Analysis

Analyzes validation patterns in the code (ref checks, length checks, etc.)

=item 3. Method Signatures

Extracts parameter names from method signatures.

=back

The tool assigns a confidence level (high/medium/low) to each schema based
on how much information it could infer.

=head1 FUZZING

When C<--fuzz> is specified, the tool will additionally run
C<App::Test::Generator::CoverageGuidedFuzzer> against each method after
schema extraction.

By default all methods with at least one known input parameter are fuzzed,
regardless of confidence level. Use C<--fuzz-all> to also attempt fuzzing
methods with no input schema (these will use purely random generation).

The fuzzer will:

=over 4

=item * Load and C<require> the target module at runtime

=item * Run coverage-guided fuzzing using the extracted schema as input spec

=item * Report any crashes or unexpected errors found

=item * Persist a corpus to C<--corpus-dir> for incremental improvement across runs

=item * Optionally minimise the corpus with C<--minimize-corpus> to keep file sizes bounded

=back

Corpus files are named C<< <corpus-dir>/<method>.json >> and are automatically
loaded on subsequent runs, so each run builds on the last.  Without
C<--minimize-corpus> the corpus grows by several entries per run; with it, only
the entries that provide unique branch coverage are retained (greedy set-cover),
plus a deduplicated set of entries from prior runs that cannot be re-evaluated.
Bug-triggering inputs are always kept regardless of coverage contribution.

=cut
132
133# ---------------------------------------------------------------------------
134# Option parsing
135# ---------------------------------------------------------------------------
136
137
9
27
my %cli_opts = (
138    help => 0,
139    man  => 0,
140);
141
142
9
33
my %extractor_opts = (
143        output_dir => 'schemas',
144        strict_pod => 'warn',
145        verbose    => 0,
146        version    => 0,
147);
148
149
9
10
my $fuzz            = 0;
150
9
10
my $fuzz_all        = 0;
151
9
11
my $fuzz_iters      = 100;
152
9
9
my $minimize_corpus = 0;
153
9
11
my $corpus_dir;       # default set after output_dir is known
154my $function_filter;  # when set, restrict to this one routine
155
156
9
34
Getopt::Long::Configure('bundling');
157
158GetOptions(
159        'output-dir|o=s'   => \$extractor_opts{output_dir},
160        'strict-pod|s=s'   => \$extractor_opts{strict_pod},
161        'function|F=s'     => \$function_filter,
162        'verbose|v'        => \$extractor_opts{verbose},
163        'version|V'        => \$extractor_opts{version},
164        'fuzz|f'           => \$fuzz,
165        'fuzz-all'         => \$fuzz_all,
166        'fuzz-iters=i'     => \$fuzz_iters,
167        'corpus-dir|c=s'   => \$corpus_dir,
168        'minimize-corpus'  => \$minimize_corpus,
169        'help|h'           => \$cli_opts{help},
170        'man|m'            => \$cli_opts{man},
171
9
50
214
) or pod2usage(2);
172
173
9
100
6138
pod2usage(-exitval => 0, -verbose => 1) if $cli_opts{help};
174
8
50
14
pod2usage(-exitval => 0, -verbose => 2) if $cli_opts{man};
175
176
8
50
17
if($extractor_opts{version}) {
177
0
0
        print $App::Test::Generator::SchemaExtractor::VERSION, "\n";
178
0
0
        exit 0;
179}
180
181
8
100
34
if ($extractor_opts{strict_pod} !~ /^(off|warn|fatal)$/) {
182
1
0
        die "Invalid --strict-pod value '$extractor_opts{strict_pod}'. Expected off, warn, or fatal";
183}
184
185
7
100
16
my $input_file = shift @ARGV or pod2usage('Error: No input file specified');
186
6
50
62
die "Error: File not found: $input_file" unless -f $input_file;
187
188# Default corpus dir sits under the output dir
189
6
67
45
$corpus_dir //= File::Spec->catdir($extractor_opts{output_dir}, 'corpus');
190
191# ---------------------------------------------------------------------------
192# Schema extraction
193# ---------------------------------------------------------------------------
194
195
6
207
print "Extracting schemas from: $input_file\n";
196
6
22
print "Output directory: $extractor_opts{output_dir}\n\n";
197
198
6
100
620
make_path($extractor_opts{output_dir}) unless -d $extractor_opts{output_dir};
199
200
6
48
my $extractor = App::Test::Generator::SchemaExtractor->new(
201        input_file => $input_file,
202        %extractor_opts,
203);
204
205
6
17
my $schemas = $extractor->extract_all();
206
207# ---------------------------------------------------------------------------
208# Optional: restrict to a single routine
209# ---------------------------------------------------------------------------
210
211
6
50
11
if (defined $function_filter) {
212
0
0
0
        unless (exists $schemas->{$function_filter}) {
213
0
0
                print STDERR "Error: routine '$function_filter' not found in $input_file\n";
214
0
0
                print STDERR "Available routines: ", join(', ', sort keys %$schemas), "\n";
215
0
0
                exit 1;
216        }
217
218        # Remove every other schema and its on-disk YAML file so that callers
219        # (e.g. t/self-fuzz.t) see exactly one .yml in the output directory.
220
0
0
        for my $name (keys %$schemas) {
221
0
0
0
                next if $name eq $function_filter;
222
0
0
                delete $schemas->{$name};
223
0
0
                my $yml = File::Spec->catfile($extractor_opts{output_dir}, "$name.yml");
224
0
0
0
                unlink $yml if -f $yml;
225        }
226
227
0
0
        print "Restricted to routine: $function_filter\n\n";
228}
229
230# ---------------------------------------------------------------------------
231# Optional: coverage-guided fuzzing
232# ---------------------------------------------------------------------------
233
234
6
6
my %fuzz_results;   # method_name => report hashref
235
236
6
100
9
if ($fuzz) {
237
3
708
        require App::Test::Generator::CoverageGuidedFuzzer;
238
3
100
221
        make_path($corpus_dir) unless -d $corpus_dir;
239
240    # Load the target module once so all methods are callable
241
3
9
    my $package = _load_target_module($input_file, $schemas);
242
243    # Try to build a default instance for object method calls.
244    # Most OO modules need a $self as the first argument.
245    # We try new() with no args, then new({}), then give up and fuzz as functions.
246
3
7
    my $instance = _try_construct($package);
247
3
50
66
    if ($instance) {
248
0
0
        print "Constructed $package instance for method calls.\n";
249    } else {
250
3
80
        print "Could not construct $package instance; fuzzing as functions.\n";
251    }
252
253
3
50
60
    print "Fuzzing with $fuzz_iters iterations per method",
254          ($fuzz_all ? ' (all methods)' : ' (methods with known inputs)'),
255          "...\n\n";
256
257
3
6
    foreach my $method (sort keys %$schemas) {
258
3
5
        my $schema = $schemas->{$method};
259
3
50
7
        my $iconf  = $schema->{_confidence}{input}{level} // 'low';
260
261
3
50
5
        unless ($fuzz_all) {
262            # Skip methods with no input schema at all — there is nothing to fuzz
263
3
0
50
33
0
7
0
            next if $iconf eq 'none' && !%{ $schema->{input} // {} };
264        }
265
266
3
11
        my $sub_ref = $package->can($method);
267
3
50
3
        unless ($sub_ref) {
268
0
0
            warn "  Skipping $method: not callable in $package\n";
269
0
0
            next;
270        }
271
272        # Skip constructors and AUTOLOAD — not suitable for direct fuzzing
273
3
50
8
        if ($method =~ /^(new|AUTOLOAD|DESTROY|import)$/) {
274            print "  Skipping $method (constructor/special method)\n"
275
0
0
0
                if $extractor_opts{verbose};
276
0
0
            next;
277        }
278
279
3
19
        my $corpus_file = File::Spec->catfile($corpus_dir, "$method.json");
280
281
3
11
        print "  Fuzzing $method ($iconf confidence)... ";
282
283
3
11
        my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
284            schema      => $schema,
285            target_sub  => $sub_ref,
286            instance    => $instance,
287            iterations  => $fuzz_iters,
288        );
289
290
3
100
22
        $fuzzer->load_corpus($corpus_file) if -f $corpus_file;
291
292
3
5
        my $report = $fuzzer->run();
293
294
3
100
5
        if ($minimize_corpus) {
295
1
3
            my $stats = $fuzzer->minimize_corpus();
296            printf "%d bugs, %d branches covered, corpus %d->%d entries\n",
297                $report->{bugs_found},
298                $report->{branches_covered},
299                $stats->{before},
300
1
10
                $stats->{after};
301        }
302
303
3
6
        $fuzzer->save_corpus($corpus_file);
304
305
3
5
        $fuzz_results{$method} = $report;
306
307        printf "%d bugs, %d branches covered\n",
308            $report->{bugs_found},
309            $report->{branches_covered}
310
3
100
34
            unless $minimize_corpus;
311    }
312
313
3
11
    print "\n";
314}
315
316# ---------------------------------------------------------------------------
317# Summary report
318# ---------------------------------------------------------------------------
319
320
6
28
print '=' x 70, "\n",
321      "EXTRACTION SUMMARY\n",
322      '=' x 70, "\n\n";
323
324
6
17
my %input_confidence_counts  = (high => 0, medium => 0, low => 0, none => 0);
325
6
12
my %output_confidence_counts = (high => 0, medium => 0, low => 0, none => 0);
326
327
6
13
foreach my $method (sort keys %$schemas) {
328
6
8
    my $schema = $schemas->{$method};
329
6
50
13
    my $iconf  = $schema->{_confidence}{input}{level}  // 'low';
330
6
50
9
    my $oconf  = $schema->{_confidence}{output}{level} // 'low';
331
6
8
    $input_confidence_counts{$iconf}++;
332
6
6
    $output_confidence_counts{$oconf}++;
333
334
6
11
6
6
20
9
    my $param_count = scalar grep { $_ !~ /^_/ } keys %{ $schema->{input} };
335
336
6
6
    my $fuzz_col = '';
337
6
100
7
    if (exists $fuzz_results{$method}) {
338
3
3
        my $r = $fuzz_results{$method};
339        $fuzz_col = $r->{bugs_found}
340            ? sprintf('  BUGS: %d', $r->{bugs_found})
341
3
50
6
            : '  fuzz: ok';
342    }
343
344
6
31
    printf "%-30s %d params  [%s input confidence] [%s output confidence]%s\n",
345        $method, $param_count, uc($iconf), uc($oconf), $fuzz_col;
346}
347
348
6
36
print "\n";
349
6
31
print 'Total methods: ', (scalar keys %$schemas), "\n";
350
6
13
print "  Input:\n";
351
6
17
print "    High confidence:   $input_confidence_counts{high}\n";
352
6
16
print "    Medium confidence: $input_confidence_counts{medium}\n";
353
6
16
print "    Low confidence:    $input_confidence_counts{low}\n";
354
6
14
print "  Output:\n";
355
6
15
print "    High confidence:   $output_confidence_counts{high}\n";
356
6
16
print "    Medium confidence: $output_confidence_counts{medium}\n";
357
6
16
print "    Low confidence:    $output_confidence_counts{low}\n";
358
6
12
print "\n";
359
360
6
50
33
21
if ($input_confidence_counts{low} > 0 || $input_confidence_counts{medium} > 0) {
361
0
0
    print "RECOMMENDATION:\n",
362          "Review the generated schemas in $extractor_opts{output_dir}/\n",
363          "Focus on methods with medium/low confidence ratings.\n\n";
364}
365
366# Fuzz bug detail
367
6
100
8
if (%fuzz_results) {
368
3
3
    my $total_bugs = 0;
369
3
8
    $total_bugs += $_->{bugs_found} for values %fuzz_results;
370
371
3
50
8
    if ($total_bugs) {
372
0
0
        print '=' x 70, "\n",
373              "FUZZING BUGS FOUND ($total_bugs total)\n",
374              '=' x 70, "\n\n";
375
376
0
0
        foreach my $method (sort keys %fuzz_results) {
377
0
0
            my $r = $fuzz_results{$method};
378
0
0
0
            next unless $r->{bugs_found};
379
0
0
            print "  $method:\n";
380
0
0
0
0
            for my $i (0 .. $#{ $r->{bugs} }) {
381
0
0
                my $bug = $r->{bugs}[$i];
382
0
0
0
                my $inp = defined($bug->{input}) ? qq("$bug->{input}") : 'undef';
383                printf "    Bug %d: input=%-30s error=%s\n",
384
0
0
                    $i + 1, $inp, $bug->{error};
385            }
386
0
0
            print "\n";
387        }
388
0
0
        print "Corpora saved to: $corpus_dir/\n\n";
389    } else {
390
3
8
        print "Fuzzing complete: no bugs found across ",
391              scalar(keys %fuzz_results), " methods.\n\n";
392    }
393}
394
395
6
100
11
if ($extractor_opts{verbose}) {
396
1
24
    print "Schemas:\n\t", Dumper($schemas);
397}
398
399
6
324
print "Schema files written to: $extractor_opts{output_dir}/\n";
400
401# ---------------------------------------------------------------------------
402# Helper: load the target module so methods become callable
403# ---------------------------------------------------------------------------
404
405sub _load_target_module {
406
3
3
5
        my ($input_file, $schemas) = @_;
407
408        # Derive the package name from the first schema entry that has 'module' set
409
3
6
        my ($package) = map  { $schemas->{$_}{module} }
410
3
3
6
8
                    grep { $schemas->{$_}{module} }
411                    keys %$schemas;
412
413
3
50
4
        die 'Could not determine package name from extracted schemas' unless $package;
414
415    # Reject anything that is not a syntactically valid Perl package name
416    # before it is used to build a require path — guards against this
417    # becoming a code-injection vector if $package is ever sourced from
418    # something less constrained than a PPI-parsed 'package' statement.
419
3
50
9
    die "Invalid package name: $package"
420        unless $package =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;
421
422    # Add the module's containing lib dir to @INC
423    # Walks up from the file looking for a 'lib' directory
424
3
40
    my $abs = File::Spec->rel2abs($input_file);
425
3
25
    my ($volume, $directory) = File::Spec->splitpath($abs);
426
3
18
    my @dirs = File::Spec->splitdir($directory);
427
428
3
3
    while (@dirs) {
429        # catpath() (not catdir()) keeps $volume attached, so this still
430        # resolves on Windows when the temp dir and the checkout live on
431        # different drive letters (a bare catdir() result is interpreted
432        # as relative to the *current* drive, not $volume's).
433
9
41
        my $candidate = File::Spec->catpath($volume, File::Spec->catdir(@dirs, 'lib'), '');
434
9
100
31
        if (-d $candidate) {
435
3
12
            lib->import($candidate);
436
3
124
            last;
437        }
438
6
7
        pop @dirs;
439    }
440
441    # require() the module by file path rather than via string eval, so
442    # $package is never compiled as Perl source.
443
3
4
    (my $module_file = $package) =~ s{::}{/}g;
444
3
3
50
3
665
    eval { require "$module_file.pm" }
445        or die "Could not load $package for fuzzing: $@";
446
447
3
5
    return $package;
448}
449
450# Try to construct a default instance of the target package for method calls.
451# Attempts new() with progressively more forgiving argument lists.
452# Returns the instance on success, undef if nothing works.
453sub _try_construct {
454
3
3
5
    my ($package) = @_;
455
456
3
6
    for my $args ([], [{}], [undef]) {
457
9
9
5
47
        my $obj = eval { $package->new(@$args) };
458
9
50
12
        next if $@;
459
0
0
0
0
        next unless defined $obj && ref $obj;
460
0
0
        return $obj;
461    }
462
463
3
4
    return undef;
464}
465