lib/App/Test/Generator/CoverageGuidedFuzzer.pm

⬅ Previous Index Next ➡
Structural Coverage (Approximate)

TER1 (Statement): 92.67%
TER2 (Branch): 81.55%
TER3 (LCSAJ): 100.0% (23/23)
Approximate LCSAJ segments: 207

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package App::Test::Generator::CoverageGuidedFuzzer;
    2: 
    3: use strict;
    4: use warnings;
    5: use Carp    qw(croak);
    6: use feature 'state';
    7: use Readonly;
    8: 
    9: # --------------------------------------------------
   10: # Fuzzing loop parameters
   11: # --------------------------------------------------
   12: Readonly my $DEFAULT_ITERATIONS   => 100;
   13: Readonly my $DEFAULT_TIMEOUT_SECS => 5;     # per-call alarm() timeout; 0 disables
   14: Readonly my $CORPUS_MUTATE_RATIO  => 0.70;  # 70% mutate, 30% explore
   15: Readonly my $RANDOM_KEEP_RATIO    => 0.20;  # keep 20% random when no coverage
   16: Readonly my $EDGE_CASE_RATIO      => 0.40;  # 40% chance to use declared edge case
   17: Readonly my $INT_BOUNDARY_RATIO   => 0.30;  # 30% chance to use boundary int
   18: Readonly my $STR_BOUNDARY_RATIO   => 0.30;  # 30% chance to use boundary length
   19: Readonly my $SEED_CORPUS_SIZE     => 5;     # initial random inputs to seed corpus
   20: Readonly my $DEFAULT_MAX_STR_LEN  => 64;
   21: Readonly my $MATCHES_REGEX_TIMEOUT_SECS => 1; # ReDoS guard for schema 'matches' patterns
   22: Readonly my $DEFAULT_MAX_ARRAY    => 4;     # max elements in random array (0..N)
   23: Readonly my $INT32_MAX            => 2**31 - 1;
   24: Readonly my $INT32_MIN            => -(2**31);
   25: 
   26: # --------------------------------------------------
   27: # Character set and interesting-string constants —
   28: # computed once at load time rather than rebuilt on
   29: # every _rand_string / _mutate_string call.
   30: # --------------------------------------------------
   31: Readonly my @RAND_CHARS => ('a'..'z', 'A'..'Z', '0'..'9', ' ', "\t", "\n", "\0");
   32: Readonly my @INTERESTING_STRINGS => (
   33: 	'', ' ', "\0", "\n", "\t",
   34: 	'a' x 256,
   35: 	'null', 'undefined',
   36: 	"'; DROP TABLE foo; --",
   37: 	'<script>alert(1)</script>',
   38: );
   39: 
   40: # --------------------------------------------------
   41: # Type name constants — used in schema dispatch
   42: # --------------------------------------------------
   43: Readonly my $TYPE_INTEGER => 'integer';
   44: Readonly my $TYPE_NUMBER  => 'number';
   45: Readonly my $TYPE_BOOLEAN => 'boolean';
   46: Readonly my $TYPE_ARRAY   => 'arrayref';
   47: Readonly my $TYPE_HASH    => 'hashref';
   48: Readonly my $TYPE_STRING  => 'string';
   49: 
   50: # --------------------------------------------------
   51: # JSON module preference order
   52: # --------------------------------------------------
   53: Readonly my @JSON_MODULES => qw(JSON::MaybeXS JSON);
   54: 
   55: our $VERSION = '0.46';
   56: 
   57: =head1 NAME
   58: 
   59: App::Test::Generator::CoverageGuidedFuzzer - AFL-style coverage-guided fuzzing for App::Test::Generator
   60: 
   61: =head1 VERSION
   62: 
   63: Version 0.46
   64: 
   65: =head1 SYNOPSIS
   66: 
   67:     use App::Test::Generator::CoverageGuidedFuzzer;
   68: 
   69:     my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
   70:         schema     => $yaml_schema,
   71:         target_sub => \&My::Module::validate,
   72:         iterations => 200,
   73:         seed       => 42,
   74:     );
   75: 
   76:     my $report = $fuzzer->run();
   77: 
   78:     # Optional: trim corpus to minimum branch-covering subset before saving
   79:     my $stats = $fuzzer->minimize_corpus();
   80:     printf "corpus %d -> %d entries\n", $stats->{before}, $stats->{after};
   81: 
   82:     $fuzzer->save_corpus('t/corpus/validate.json');
   83: 
   84: =head1 DESCRIPTION
   85: 
   86: Implements coverage-guided fuzzing on top of App::Test::Generator's
   87: existing schema-driven input generation. Instead of purely random
   88: generation it:
   89: 
   90: =over 4
   91: 
   92: =item 1. Generates or mutates a structured input
   93: 
   94: =item 2. Runs the target sub under Devel::Cover to capture branch hits
   95: 
   96: =item 3. Keeps inputs that discover new branches in a corpus
   97: 
   98: =item 4. Preferentially mutates corpus entries in future iterations
   99: 
  100: =back
  101: 
  102: This is the Perl equivalent of what AFL/libFuzzer do at the byte level,
  103: but operating on typed, schema-validated Perl data structures.
  104: 
  105: =head1 METHODS
  106: 
  107: =head2 new
  108: 
  109: Construct a new coverage-guided fuzzer.
  110: 
  111:     my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
  112:         schema     => $yaml_schema,
  113:         target_sub => \&My::Module::validate,
  114:         iterations => 200,
  115:         seed       => 42,
  116:         instance   => $obj,   # optional pre-built object for method calls
  117:     );
  118: 
  119: =head3 Arguments
  120: 
  121: =over 4
  122: 
  123: =item * C<schema>
  124: 
  125: A hashref representing the parsed YAML schema for the target function.
  126: Required.
  127: 
  128: =item * C<target_sub>
  129: 
  130: A CODE reference to the function under test. Required.
  131: 
  132: =item * C<iterations>
  133: 
  134: Number of fuzzing iterations to run. Optional - defaults to 100.
  135: 
  136: =item * C<seed>
  137: 
  138: Random seed for reproducible runs. Optional - defaults to C<time()>.
  139: 
  140: =item * C<instance>
  141: 
  142: An optional pre-built object to use as the invocant when calling the
  143: target sub as a method.
  144: 
  145: =item * C<timeout>
  146: 
  147: Seconds to allow each C<target_sub> call before it is aborted via
  148: C<alarm()> and recorded as a bug. Optional - defaults to 5. Set to 0
  149: to disable the timeout (e.g. for target subs that legitimately block).
  150: 
  151: =back
  152: 
  153: =head3 Returns
  154: 
  155: A blessed hashref. Croaks if C<schema> or C<target_sub> is missing.
  156: 
  157: =head3 API specification
  158: 
  159: =head4 input
  160: 
  161:     {
  162:         schema     => { type => HASHREF },
  163:         target_sub => { type => CODEREF },
  164:         iterations => { type => SCALAR,  optional => 1 },
  165:         seed       => { type => SCALAR,  optional => 1 },
  166:         instance   => { type => OBJECT,  optional => 1 },
  167:         timeout    => { type => SCALAR,  optional => 1 },
  168:     }
  169: 
  170: =head4 output
  171: 
  172:     {
  173:         type => OBJECT,
  174:         isa  => 'App::Test::Generator::CoverageGuidedFuzzer',
  175:     }
  176: 
  177: =head3 EXAMPLE
  178: 
  179:     my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
  180:         schema     => { name => { type => 'string' } },
  181:         target_sub => sub { length($_[0]) },
  182:         iterations => 50,
  183:         seed       => 1234,
  184:     );
  185: 
  186: =head3 MESSAGES
  187: 
  188: =over 4
  189: 
  190: =item C<schema required>
  191: 
  192: C<schema> was not supplied or was falsy (e.g. C<undef> or C<0>).

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  193: 
  194: =item C<target_sub required>
  195: 
  196: C<target_sub> was not supplied or was falsy.

  Mutants (Total: 2, Killed: 2, Survived: 0)
  197: 
  198: =back
  199: 
  200: =head3 FORMAL SPECIFICATION
  201: 
  202: Pre:  C<defined schema ∧ ref(target_sub) eq 'CODE'>
  203: 
  204: Post: C<ref(result) eq 'App::Test::Generator::CoverageGuidedFuzzer'>
  205:       ∧ C<result-E<gt>{seed}> passed to C<srand()>
  206:       ∧ C<result-E<gt>{corpus} eq []>
  207: 
  208: =cut
  209: 
  210: sub new {
●211 → 242 → 246  211: 	my ($class, %args) = @_;
  212: 
  213: 	croak 'schema required'     unless $args{schema};
  214: 	croak 'target_sub required' unless $args{target_sub};
  215: 
  216: 	my $self = bless {
  217: 		schema     => $args{schema},
  218: 		target_sub => $args{target_sub},
  219: 		instance   => $args{instance},
  220: 		iterations => $args{iterations} // $DEFAULT_ITERATIONS,
  221: 		seed       => $args{seed}       // time(),
  222: 		timeout    => $args{timeout}    // $DEFAULT_TIMEOUT_SECS,
  223: 		corpus     => [],   # [{input => ..., coverage => {...}}]
  224: 		covered    => {},   # "file:line:branch" => 1
  225: 		bugs       => [],   # [{input => ..., error => ...}]
  226: 		stats      => {
  227: 			total       => 0,
  228: 			interesting => 0,
  229: 			bugs        => 0,
  230: 			coverage    => 0,
  231: 		},
  232: 		_cover_available => undef,
  233: 	}, $class;
  234: 
  235: 	srand($self->{seed});
  236: 
  237: 	# Probe for Devel::Cover availability once at construction time
  238: 	$self->{_cover_available} = eval { require Devel::Cover; 1 } ? 1 : 0;
  239: 
  240: 	# Warn once per process if coverage guidance is unavailable
  241: 	state $cover_warned = 0;
  242: 	if(!$self->{_cover_available} && !$cover_warned++) {
  243: 		warn 'Devel::Cover not available; fuzzing without coverage guidance.';
  244: 	}
  245: 
  246: 	return $self;
  247: }
  248: 
  249: =head2 run
  250: 
  251: Run the coverage-guided fuzzing loop and return a summary report.
  252: 
  253:     my $report = $fuzzer->run();
  254:     printf "Branches covered: %d\n", $report->{branches_covered};
  255:     printf "Bugs found:       %d\n", $report->{bugs_found};
  256: 
  257: =head3 Arguments
  258: 

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

  259: None beyond C<$self>.
  260: 
  261: =head3 Returns
  262: 
  263: A hashref with keys C<total_iterations>, C<interesting_inputs>,
  264: C<corpus_size>, C<branches_covered>, C<bugs_found>, and C<bugs>.
  265: 
  266: =head3 Notes
  267: 
  268: A C<target_sub> call that dies is only recorded in C<bugs> when the
  269: input that triggered it is valid per C<schema>. A die triggered by an
  270: input the schema itself marks invalid (e.g. out of the declared
  271: C<min>/C<max> range) is expected behaviour, not a bug, and is silently
  272: discarded.

  Mutants (Total: 2, Killed: 2, Survived: 0)
  273: 
  274: =head3 API specification
  275: 
  276: =head4 input
  277: 
  278:     {
  279:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  280:     }
  281: 
  282: =head4 output
  283: 
  284:     {
  285:         type => HASHREF,
  286:         keys => {
  287:             total_iterations   => { type => SCALAR  },
  288:             interesting_inputs => { type => SCALAR  },
  289:             corpus_size        => { type => SCALAR  },
  290:             branches_covered   => { type => SCALAR  },
  291:             bugs_found         => { type => SCALAR  },
  292:             bugs               => { type => ARRAYREF },
  293:         },
  294:     }
  295: 
  296: =head3 EXAMPLE
  297: 
  298:     my $report = $fuzzer->run();
  299:     printf "Iterations:  %d\n", $report->{total_iterations};
  300:     printf "Corpus size: %d\n", $report->{corpus_size};
  301:     printf "Bugs found:  %d\n", $report->{bugs_found};
  302:     for my $bug (@{ $report->{bugs} }) {
  303:         printf "  input=%s  error=%s\n", $bug->{input}, $bug->{error};
  304:     }
  305: 
  306: =head3 FORMAL SPECIFICATION
  307: 
  308: Pre:  C<self-E<gt>{schema}> and C<self-E<gt>{target_sub}> are set
  309: 
  310: Post: C<result-E<gt>{total_iterations} == self-E<gt>{iterations}>
  311:       ∧ C<result-E<gt>{corpus_size} == scalar @{self-E<gt>{corpus}}>
  312:       ∧ C<result-E<gt>{bugs_found} == scalar @{self-E<gt>{bugs}}>
  313: 
  314: =head3 PSEUDOCODE
  315: 
  316:     seed corpus with SEED_CORPUS_SIZE random inputs
  317:     for i in 1..iterations:
  318:         if corpus non-empty and rand < CORPUS_MUTATE_RATIO:
  319:             input = mutate(random corpus entry)
  320:         else:
  321:             input = generate_random()
  322:         run target_sub(input), record coverage and bugs
  323:     return report hashref
  324: 
  325: =cut
  326: 
  327: sub run {
●328 → 334 → 350  328: 	my ($self) = @_;
  329: 
  330: 	# Phase 1: seed the corpus with a small set of random inputs
  331: 	$self->_seed_corpus();
  332: 
  333: 	# Phase 2: main fuzzing loop — alternate between mutation and exploration
  334: 	for my $i (1 .. $self->{iterations}) {
  335: 		my $input;
  336: 
  337: 		if(@{ $self->{corpus} } && rand() < $CORPUS_MUTATE_RATIO) {
  338: 			# Mutate a randomly chosen corpus entry
  339: 			my $parent = $self->{corpus}[ int(rand(@{ $self->{corpus} })) ];
  340: 			$input = $self->_mutate($parent->{input});
  341: 		} else {
  342: 			# Fresh random generation for exploration
  343: 			$input = $self->_generate_random();
  344: 		}
  345: 
  346: 		$self->_run_one($input);
  347: 		$self->{stats}{total}++;
  348: 	}
  349: 
  350: 	$self->{stats}{coverage} = scalar keys %{ $self->{covered} };
  351: 	return $self->_build_report();
  352: }
  353: 
  354: =head2 corpus
  355: 
  356: Return the accumulated corpus as an arrayref of hashrefs with keys
  357: C<input> and C<coverage>.
  358: 
  359:     my $corpus = $fuzzer->corpus();
  360: 
  361: =head3 API specification
  362: 
  363: =head4 input
  364: 
  365:     { self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' } }
  366: 
  367: =head4 output
  368: 
  369:     { type => ARRAYREF }
  370: 
  371: =head3 EXAMPLE
  372: 
  373:     my $corpus = $fuzzer->corpus();
  374:     printf "%d entries in corpus\n", scalar @{$corpus};
  375:     # Each entry: { input => ..., coverage => { 'file:line:branch' => 1, ... } }
  376: 
  377: =cut
  378: 
  379: sub corpus { $_[0]->{corpus} }
  380: 
  381: =head2 bugs
  382: 
  383: Return bugs found as an arrayref of hashrefs with keys C<input> and
  384: C<error>.
  385: 
  386:     my $bugs = $fuzzer->bugs();
  387: 
  388: =head3 API specification
  389: 
  390: =head4 input
  391: 
  392:     { self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' } }
  393: 
  394: =head4 output
  395: 
  396:     { type => ARRAYREF }
  397: 
  398: =head3 EXAMPLE
  399: 
  400:     my $bugs = $fuzzer->bugs();
  401:     for my $b (@{$bugs}) {
  402:         printf "Bug: input=%s  error=%s\n", $b->{input}, $b->{error};
  403:     }
  404: 
  405: =cut
  406: 
  407: sub bugs { $_[0]->{bugs} }
  408: 
  409: =head2 save_corpus
  410: 
  411: Serialise the corpus to a JSON file for replay or extension on future
  412: runs.
  413: 
  414:     $fuzzer->save_corpus('t/corpus/validate.json');
  415: 
  416: =head3 Arguments
  417: 
  418: =over 4
  419: 
  420: =item * C<$path>
  421: 
  422: Path to write the JSON corpus file. Required.
  423: 
  424: =back
  425: 
  426: =head3 Returns
  427: 
  428: Nothing. Croaks if the file cannot be written or no JSON module is
  429: available.
  430: 
  431: =head3 Side effects
  432: 
  433: Writes a JSON file to C<$path>.
  434: 
  435: =head3 API specification
  436: 
  437: =head4 input
  438: 
  439:     {
  440:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  441:         path => { type => SCALAR },
  442:     }
  443: 
  444: =head4 output
  445: 
  446:     { type => UNDEF }
  447: 
  448: =head3 EXAMPLE
  449: 
  450:     $fuzzer->run();
  451:     $fuzzer->minimize_corpus();
  452:     $fuzzer->save_corpus('t/corpus/my_func.json');
  453: 
  454: =head3 MESSAGES
  455: 
  456: =over 4
  457: 
  458: =item C<path required>
  459: 
  460: No path argument was supplied.
  461: 
  462: =item C<Cannot write corpus to $path: $!>
  463: 
  464: The file could not be opened for writing (permissions, missing directory, etc.).

  Mutants (Total: 2, Killed: 2, Survived: 0)
  465: 
  466: =item C<No JSON module available; install JSON or JSON::MaybeXS>
  467: 
  468: Neither C<JSON::MaybeXS> nor C<JSON> is installed.
  469: 
  470: =back
  471: 
  472: =cut
  473: 
  474: sub save_corpus {
  475: 	my ($self, $path) = @_;
  476: 
  477: 	croak 'path required' unless defined $path;
  478: 
  479: 	my $json = _load_json_module();
  480: 
  481: 	open my $fh, '>', $path
  482: 		or croak "Cannot write corpus to $path: $!";
  483: 
  484: 	print $fh $json->new->pretty->encode({
  485: 		seed   => $self->{seed},
  486: 		corpus => [ map { { input => $_->{input} } } @{ $self->{corpus} } ],
  487: 		bugs   => $self->{bugs},
  488: 	});
  489: 
  490: 	close $fh;
  491: }
  492: 
  493: =head2 load_corpus
  494: 

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  495: Load a previously saved corpus JSON file, pre-seeding the fuzzer so
  496: it continues from where it left off.
  497: 
  498:     $fuzzer->load_corpus('t/corpus/validate.json');
  499: 
  500: =head3 Arguments
  501: 
  502: =over 4
  503: 
  504: =item * C<$path>
  505: 
  506: Path to the JSON corpus file to load. Required.
  507: 
  508: =back
  509: 
  510: =head3 Returns
  511: 
  512: Nothing. Croaks if the file cannot be read or no JSON module is
  513: available.
  514: 
  515: =head3 Side effects
  516: 
  517: Appends loaded entries to C<< $self->{corpus} >>.
  518: 
  519: =head3 API specification

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  520: 
  521: =head4 input
  522: 
  523:     {
  524:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  525:         path => { type => SCALAR },
  526:     }
  527: 
  528: =head4 output

  Mutants (Total: 1, Killed: 1, Survived: 0)
  529: 
  530:     { type => UNDEF }
  531: 
  532: =head3 EXAMPLE
  533: 
  534:     my $fuzzer2 = App::Test::Generator::CoverageGuidedFuzzer->new(

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  535:         schema     => $schema,
  536:         target_sub => \&My::Module::validate,
  537:     );
  538:     $fuzzer2->load_corpus('t/corpus/my_func.json');
  539:     my $report = $fuzzer2->run();
  540: 
  541: =head3 MESSAGES
  542: 
  543: =over 4
  544: 
  545: =item C<path required>
  546: 
  547: No path argument was supplied.
  548: 
  549: =item C<Cannot read corpus from $path: $!>
  550: 
  551: The file could not be opened for reading (missing file, permissions, etc.).
  552: 
  553: =back
  554: 
  555: =head3 FORMAL SPECIFICATION
  556: 
  557: Note: C<load_corpus> does B<not> restore C<bugs> from the JSON file —
  558: the C<bugs> array in the JSON is written by C<save_corpus> but ignored on load.
  559: The loaded fuzzer starts with an empty C<bugs> list.  Seed values are also not
  560: restored; the constructor-supplied seed is retained.
  561: 
  562: =cut
  563: 
  564: sub load_corpus {
●565 → 579 → 0  565: 	my ($self, $path) = @_;
  566: 
  567: 	croak 'path required' unless defined $path;
  568: 
  569: 	my $json = _load_json_module();
  570: 
  571: 	open my $fh, '<', $path
  572: 		or croak "Cannot read corpus from $path: $!";
  573: 
  574: 	my $data = $json->new->decode(do { local $/; <$fh> });
  575: 	close $fh;
  576: 
  577: 	# Load corpus entries with empty coverage — coverage state from a
  578: 	# previous process cannot be restored, only the inputs themselves
  579: 	for my $entry (@{ $data->{corpus} // [] }) {
  580: 		push @{ $self->{corpus} }, {
  581: 			input    => $entry->{input},
  582: 			coverage => {},
  583: 		};
  584: 	}
  585: }
  586: 
  587: =head2 minimize_corpus
  588: 
  589: Reduce the corpus to the smallest subset that still covers every
  590: branch hit by the full corpus, using a greedy set-cover algorithm.
  591: 
  592: Entries without branch data (loaded from a previous run, or kept by
  593: random sampling when Devel::Cover is unavailable) are deduplicated by
  594: input fingerprint and retained in full — they cannot be evaluated for
  595: coverage contribution without re-running them.  Bug-triggering inputs
  596: are always kept regardless of coverage contribution.
  597: 
  598:     my $stats = $fuzzer->minimize_corpus();
  599:     printf "Corpus: %d -> %d entries (%d branches covered)\n",
  600:         $stats->{before}, $stats->{after}, $stats->{branches};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  601: 
  602: =head3 Returns
  603: 
  604: A hashref with keys C<before> (corpus size before), C<after> (corpus
  605: size after), and C<branches> (total unique branches still covered).
  606: 
  607: =head3 API specification
  608: 
  609: =head4 input
  610: 
  611:     { self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' } }
  612: 
  613: =head4 output
  614: 
  615:     {
  616:         type       => HASHREF,
  617:         constraint => sub { defined $_[0]{before} && defined $_[0]{after} && defined $_[0]{branches} },
  618:     }
  619: 
  620: =head3 EXAMPLE
  621: 
  622:     $fuzzer->run();
  623:     my $stats = $fuzzer->minimize_corpus();
  624:     printf "Corpus: %d -> %d entries (%d branches)\n",
  625:         $stats->{before}, $stats->{after}, $stats->{branches};
  626:     $fuzzer->save_corpus('t/corpus/my_func.json');
  627: 
  628: =head3 FORMAL SPECIFICATION
  629: 
  630: Post: C<result-E<gt>{before}> == pre corpus size
  631:       ∧ C<result-E<gt>{after}> ≤ C<result-E<gt>{before}>
  632:       ∧ C<scalar @{self-E<gt>{corpus}}> == C<result-E<gt>{after}>
  633:       ∧ every branch covered by the original corpus is still covered
  634:         by the minimized corpus
  635:       ∧ every bug-triggering input survives minimization
  636: 
  637: =head3 PSEUDOCODE
  638: 

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  639:     partition corpus into with-coverage and without-coverage entries
  640:     greedy set-cover: repeatedly pick entry covering most uncovered branches
  641:     deduplicate without-coverage entries by JSON fingerprint
  642:     unconditionally add all bug inputs not already in minimized set
  643:     replace self.corpus with minimized list
  644:     return { before, after, branches }
  645: 
  646: =cut
  647: 
  648: sub minimize_corpus {
●649 → 664 → 683  649: 	my ($self) = @_;
  650: 
  651: 	my @all    = @{ $self->{corpus} };
  652: 	my $before = scalar @all;
  653: 
  654: 	my @with_cov    = grep {  %{ $_->{coverage} } } @all;
  655: 	my @without_cov = grep { !%{ $_->{coverage} } } @all;
  656: 
  657: 	# Greedy set-cover: find the smallest subset of with-coverage entries
  658: 	# that still covers every branch seen across the whole corpus.
  659: 	my %uncovered;
  660: 	$uncovered{$_} = 1 for map { keys %{ $_->{coverage} } } @with_cov;
  661: 	my $total_branches = scalar keys %uncovered;
  662: 
  663: 	my @selected;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  664: 	while (%uncovered && @with_cov) {
  665: 		my ($best, $best_idx, $best_n) = (undef, -1, 0);
  666: 		for my $i (0 .. $#with_cov) {
  667: 			my $n = grep { $uncovered{$_} } keys %{ $with_cov[$i]{coverage} };

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

  668: 			if ($n > $best_n) {
  669: 				$best_n   = $n;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  670: 				$best_idx = $i;
  671: 				$best     = $with_cov[$i];
  672: 			}
  673: 		}
  674: 		last unless $best_n;
  675: 
  676: 		push @selected, $best;
  677: 		splice @with_cov, $best_idx, 1;
  678: 		delete $uncovered{$_} for keys %{ $best->{coverage} };
  679: 	}
  680: 
  681: 	# Deduplicate no-coverage entries by input fingerprint so that repeated
  682: 	# loads of the same corpus file do not cause the entry count to grow.
●683 → 685 → 691  683: 	my %seen;
  684: 	my @deduped;
  685: 	for my $entry (@without_cov) {
  686: 		my $key = _fingerprint($entry->{input});
  687: 		next if $seen{$key}++;
  688: 		push @deduped, $entry;
  689: 	}
  690: 
●691 → 696 → 703  691: 	my @minimized = (@selected, @deduped);
  692: 
  693: 	# Bug-triggering inputs are always kept — they are the most valuable
  694: 	# findings regardless of whether they add unique branch coverage.
  695: 	my %kept = map { _fingerprint($_->{input}) => 1 } @minimized;
  696: 	for my $bug (@{ $self->{bugs} }) {
  697: 		my $key = _fingerprint($bug->{input});
  698: 		unless ($kept{$key}++) {
  699: 			push @minimized, { input => $bug->{input}, coverage => {} };

  Mutants (Total: 2, Killed: 2, Survived: 0)
  700: 		}
  701: 	}
  702: 
  703: 	$self->{corpus} = \@minimized;
  704: 
  705: 	return {
  706: 		before   => $before,
  707: 		after    => scalar @minimized,
  708: 		branches => $total_branches,
  709: 	};
  710: }
  711: 
  712: # --------------------------------------------------
  713: # _fingerprint
  714: #
  715: # Purpose:    Produce a stable, canonical string key
  716: #             for an arbitrary Perl value, for use as
  717: #             a deduplication key.
  718: #
  719: # Entry:      $val - any Perl value (scalar, ref, undef).
  720: # Exit:       Returns a deterministic string.
  721: # Side effects: None.
  722: #
  723: # Notes:      Uses the JSON module in canonical mode so
  724: #             hash keys are always sorted.  Avoids

  Mutants (Total: 2, Killed: 2, Survived: 0)
  725: #             Data::Dumper whose output includes blessed

  Mutants (Total: 2, Killed: 2, Survived: 0)
  726: #             class names that vary across Perl versions.
  727: # --------------------------------------------------
  728: sub _fingerprint {
●729 → 732 → 736  729: 	my ($val) = @_;
  730: 	return 'null' unless defined $val;

					

					Mutants (Total: 4, Killed: 1, Survived: 3)
					

  731: 	state $encoder;
  732: 	unless ($encoder) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
  733: 		my $mod = _load_json_module();
  734: 		$encoder = eval { $mod->new->canonical(1) };
  735: 	}
  736: 	return eval { $encoder->encode($val) } // "$val";

  Mutants (Total: 3, Killed: 3, Survived: 0)
  737: }

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  738: 

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  739: # --------------------------------------------------

  Mutants (Total: 2, Killed: 2, Survived: 0)
  740: # _load_json_module

  Mutants (Total: 2, Killed: 2, Survived: 0)
  741: #

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  742: # Find and load the first available JSON
  743: #     module from the preference list.
  744: #
  745: # Entry:      None.
  746: # Exit:       Returns the name of the loaded module.
  747: #             Croaks if none are available.
  748: #
  749: # Side effects: Loads a JSON module into the process.
  750: #
  751: # Notes:      Uses explicit require rather than string
  752: #             eval for safety. JSON::MaybeXS is
  753: #             preferred over JSON.
  754: # --------------------------------------------------
  755: sub _load_json_module {
●756 → 758 → 767  756: 	state $cached;
  757: 	return $cached if defined $cached;
  758: 	for my $mod (@JSON_MODULES) {
  759: 		# Convert package name to file path — require $var does not
  760: 		# do the :: -> / conversion that bareword require does
  761: 		(my $file = $mod) =~ s{::}{/}g;
  762: 		$file .= '.pm';

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

  763: 		if (eval { require $file; 1 }) {
  764: 			return $cached = $mod;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  765: 		}
  766: 	}
  767: 	croak 'No JSON module available; install JSON or JSON::MaybeXS';

  Mutants (Total: 2, Killed: 2, Survived: 0)
  768: }
  769: 
  770: # --------------------------------------------------
  771: # _run_one
  772: #
  773: # Run the target sub with a single input,
  774: #     record coverage, detect bugs, and update
  775: #     the corpus if the input is interesting.
  776: #
  777: # Entry:      $input - the value to pass to target_sub.
  778: #
  779: # Exit:       Returns nothing. Updates $self->{corpus},
  780: #             $self->{bugs}, and $self->{covered}.
  781: #
  782: # Side effects: Calls target_sub. May update corpus
  783: #               and covered hashes.
  784: #
  785: # Notes:      When Devel::Cover is available, coverage
  786: #             is captured via _run_with_cover.

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  787: #             Unexpected warnings are treated as soft
  788: #             bugs if they match known warning patterns.
  789: # --------------------------------------------------
  790: sub _run_one {
●791 → 795 → 829  791: 	my ($self, $input) = @_;
  792: 
  793: 	my ($result, $error, $coverage);
  794: 
  795: 	if($self->{_cover_available}) {
  796: 		$coverage = $self->_run_with_cover($input, \$result, \$error);
  797: 	} else {
  798: 		$coverage = {};
  799: 
  800: 		# Include instance as invocant for method calls
  801: 		my @call_args = defined($self->{instance})
  802: 			? ($self->{instance}, $input)
  803: 			: ($input);
  804: 
  805: 		my @warnings;
  806: 		eval {
  807: 			local $SIG{__WARN__} = sub { push @warnings, @_ };
  808: 			local $SIG{__DIE__};
  809: 			# A hanging target_sub call would otherwise hang the
  810: 			# whole fuzzing run — alarm() bounds it and surfaces
  811: 			# the timeout as a recorded bug instead.

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

  812: 			local $SIG{ALRM} = sub { die "target_sub timed out after $self->{timeout}s\n" };
  813: 			alarm($self->{timeout}) if $self->{timeout};
  814: 			$result = $self->{target_sub}->(@call_args);
  815: 		};
  816: 		alarm(0) if $self->{timeout};
  817: 		$error = $@ if $@;
  818: 
  819: 		# Treat unexpected warnings matching known bad patterns as soft bugs

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  820: 		if(!defined($error) && @warnings) {
  821: 			my $w = join '', @warnings;
  822: 			$error = "warning: $w"

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  823: 				if $w =~ /uninitialized|undefined|blessed|invalid/i;
  824: 		}
  825: 	}
  826: 
  827: 	# Record bugs — only when the input was valid per the schema.
  828: 	# A die on invalid input is correct behaviour, not a bug.
●829 → 829 → 835  829: 	if($error && $self->_input_is_valid($input)) {
  830: 		push @{ $self->{bugs} }, { input => $input, error => "$error" };
  831: 		$self->{stats}{bugs}++;
  832: 	}
  833: 
  834: 	# Keep the input in the corpus if it exercised new branches
●835 → 835 → 0  835: 	if($self->_is_interesting($coverage)) {
  836: 		push @{ $self->{corpus} }, { input => $input, coverage => $coverage };
  837: 		$self->_update_covered($coverage);
  838: 		$self->{stats}{interesting}++;
  839: 	}
  840: }
  841: 
  842: # --------------------------------------------------
  843: # _run_with_cover
  844: #
  845: # Purpose:    Run the target sub with Devel::Cover
  846: #             active and return the set of newly hit
  847: #             branches as a hashref.
  848: #
  849: # Entry:      $input      - value to pass to target_sub.
  850: #             $result_ref - scalar ref to store result.
  851: #             $error_ref  - scalar ref to store error.
  852: #
  853: # Exit:       Returns a hashref of newly hit branch
  854: #             keys ("file:line:branch").
  855: #
  856: # Side effects: Calls Devel::Cover::start/stop.
  857: #               Sets $$result_ref and $$error_ref.
  858: #
  859: # Notes:      Snapshot comparison is imprecise for
  860: #             concurrent use but correct for single-
  861: #             threaded fuzzing. Instance is passed
  862: #             as invocant when set. Devel::Cover state
  863: #             only grows, so this iteration's "before"
  864: #             is exactly the previous iteration's
  865: #             "after" -- cached in $self to avoid two

  Mutants (Total: 2, Killed: 2, Survived: 0)
  866: #             full Devel::Cover walks per iteration.
  867: # --------------------------------------------------
  868: sub _run_with_cover {
●869 → 898 → 902  869: 	my ($self, $input, $result_ref, $error_ref) = @_;
  870: 
  871: 	Devel::Cover::start() if Devel::Cover->can('start');
  872: 
  873: 	my $before_ref = $self->{_last_cover_snapshot} || {};
  874: 	my %before = %{$before_ref};
  875: 
  876: 	# Include instance as invocant for method calls
  877: 	my @call_args = defined($self->{instance})
  878: 		? ($self->{instance}, $input)
  879: 		: ($input);
  880: 
  881: 	eval {
  882: 		local $SIG{__DIE__};
  883: 		# See _run_one() — bound the call so a hanging target_sub
  884: 		# cannot hang the whole fuzzing run.
  885: 		local $SIG{ALRM} = sub { die "target_sub timed out after $self->{timeout}s\n" };
  886: 		alarm($self->{timeout}) if $self->{timeout};
  887: 		$$result_ref = $self->{target_sub}->(@call_args);
  888: 	};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  889: 	alarm(0) if $self->{timeout};
  890: 	$$error_ref = $@ if $@;
  891: 
  892: 	my $after = $self->_snapshot_cover();

  Mutants (Total: 1, Killed: 1, Survived: 0)
  893: 	$self->{_last_cover_snapshot} = $after;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  894: 	Devel::Cover::stop() if Devel::Cover->can('stop');
  895: 
  896: 	# Return only branches newly hit in this call

  Mutants (Total: 2, Killed: 2, Survived: 0)
  897: 	my %delta;
  898: 	for my $key (keys %{$after}) {
  899: 		$delta{$key} = 1 unless exists $before{$key};
  900: 	}
  901: 
  902: 	return \%delta;
  903: }
  904: 
  905: # --------------------------------------------------
  906: # _snapshot_cover
  907: #
  908: # Purpose:    Take a lightweight snapshot of the
  909: #             currently hit branches from Devel::Cover.
  910: #
  911: # Entry:      None beyond $self.
  912: # Exit:       Returns a hash of "file:line:branch" keys.
  913: #

  Mutants (Total: 2, Killed: 2, Survived: 0)
  914: # Side effects: Reads Devel::Cover internal state.
  915: #
  916: # Notes:      Falls back to empty hash if the
  917: #             Devel::Cover API is not accessible.
  918: #             All errors are silently swallowed since
  919: #             coverage is best-effort.
  920: # --------------------------------------------------
  921: sub _snapshot_cover {
  922: 	my ($self) = @_;
  923: 	my %snap;
  924: 
  925: 	eval {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  926: 		my $cover = Devel::Cover::get_coverage();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  927: 		return unless $cover;
  928: 
  929: 		for my $file (keys %{$cover}) {
  930: 			my $branch = $cover->{$file}{branch} or next;
  931: 			for my $line (keys %{$branch}) {

  Mutants (Total: 2, Killed: 2, Survived: 0)
  932: 				for my $b (0 .. $#{ $branch->{$line} }) {
  933: 					$snap{"$file:$line:$b"} = 1
  934: 						if $branch->{$line}[$b];

  Mutants (Total: 2, Killed: 2, Survived: 0)
  935: 				}
  936: 			}
  937: 		}
  938: 	};
  939: 
  940: 	return \%snap;
  941: }
  942: 
  943: # --------------------------------------------------
  944: # _is_interesting
  945: #
  946: # Purpose:    Return true if the coverage hashref
  947: #             contains any branch not yet in the
  948: #             global covered set.
  949: #
  950: # Entry:      $coverage - hashref of branch keys.
  951: # Exit:       Returns 1 if interesting, 0 otherwise.
  952: #
  953: # Side effects: None.
  954: #
  955: # Notes:      When no coverage data is available,
  956: #             keeps a random sample of inputs at
  957: #             RANDOM_KEEP_RATIO so the corpus still

  Mutants (Total: 2, Killed: 2, Survived: 0)
  958: #             grows even without branch feedback.
  959: # --------------------------------------------------
  960: sub _is_interesting {
●961 → 964 → 969  961: 	my ($self, $coverage) = @_;

  Mutants (Total: 1, Killed: 1, Survived: 0)
  962: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
  963: 	# Check for any newly covered branch

  Mutants (Total: 5, Killed: 5, Survived: 0)
  964: 	for my $key (keys %{$coverage}) {

  Mutants (Total: 5, Killed: 5, Survived: 0)
  965: 		return 1 unless $self->{covered}{$key};
  966: 	}
  967: 
  968: 	# No coverage data — keep a random sample to grow the corpus

  Mutants (Total: 2, Killed: 2, Survived: 0)
  969: 	return rand() < $RANDOM_KEEP_RATIO unless %{$coverage};

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

  970: 

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

  971: 	return 0;
  972: }
  973: 
  974: # --------------------------------------------------

  Mutants (Total: 5, Killed: 5, Survived: 0)
  975: # _update_covered

  Mutants (Total: 5, Killed: 5, Survived: 0)
  976: #

  Mutants (Total: 1, Killed: 1, Survived: 0)
  977: # Purpose:    Merge newly covered branches into the
  978: #             global covered set.
  979: #
  980: # Entry:      $coverage - hashref of branch keys.
  981: # Exit:       Returns nothing. Updates $self->{covered}.
  982: # Side effects: Modifies $self->{covered}.
  983: # --------------------------------------------------
  984: sub _update_covered {
  985: 	my ($self, $coverage) = @_;
  986: 	$self->{covered}{$_} = 1 for keys %{$coverage};
  987: }
  988: 
  989: # --------------------------------------------------
  990: # _generate_random
  991: #
  992: # Purpose:    Generate a random input value from the

  Mutants (Total: 2, Killed: 2, Survived: 0)
  993: #             top-level schema input specification.
  994: #
  995: # Entry:      None beyond $self.
  996: # Exit:       Returns a randomly generated value.

  Mutants (Total: 2, Killed: 2, Survived: 0)
  997: # Side effects: None.
  998: # --------------------------------------------------
  999: sub _generate_random {

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1000: 	my ($self) = @_;
 1001: 	return $self->_generate_for_schema($self->{schema}{input});
 1002: }

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1003: 
 1004: # --------------------------------------------------
 1005: # _generate_for_schema

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1006: #
 1007: # Purpose:    Recursively generate a random value
 1008: #             matching a schema specification hashref.
 1009: #
 1010: # Entry:      $spec - schema spec hashref or scalar
 1011: #             type hint.
 1012: #
 1013: # Exit:       Returns a generated value appropriate
 1014: #             for the spec type, or undef if spec is
 1015: #             absent or 'undef'.
 1016: #
 1017: # Side effects: None.
 1018: #
 1019: # Notes:      Edge cases declared in edge_case_array
 1020: #             are selected at EDGE_CASE_RATIO frequency
 1021: #             to bias toward known interesting values.
 1022: # --------------------------------------------------
 1023: sub _generate_for_schema {
●1024 → 1032 → 1038 1024: 	my ($self, $spec) = @_;
 1025: 
 1026: 	return undef unless defined $spec;
 1027: 	return undef if $spec eq 'undef';

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1028: 
 1029: 	my $type = ref($spec) ? ($spec->{type} // $TYPE_STRING) : $TYPE_STRING;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1030: 
 1031: 	# Bias toward declared edge cases at EDGE_CASE_RATIO frequency
 1032: 	if(ref($spec) && $spec->{edge_case_array} && rand() < $EDGE_CASE_RATIO) {
 1033: 		my @ec = @{ $spec->{edge_case_array} };

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1034: 		return $ec[ int(rand(@ec)) ];

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1035: 	}
 1036: 

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1037: 	# Dispatch to type-specific generator
●1038 → 1038 → 0 1038: 	if    ($type eq $TYPE_INTEGER) { return $self->_rand_int($spec)    }

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1039: 	elsif ($type eq $TYPE_NUMBER)  { return $self->_rand_num($spec)    }
 1040: 	elsif ($type eq $TYPE_BOOLEAN) { return int(rand(2))               }
 1041: 	elsif ($type eq $TYPE_ARRAY)   { return $self->_rand_array($spec)  }
 1042: 	elsif ($type eq $TYPE_HASH)    { return $self->_rand_hash($spec)   }

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1043: 	else                           { return $self->_rand_string($spec) }
 1044: }
 1045: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1046: # --------------------------------------------------
 1047: # _rand_int
 1048: #
 1049: # Purpose:    Generate a random integer within the

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1050: #             spec's min/max range, biased toward
 1051: #             boundary values at INT_BOUNDARY_RATIO.
 1052: #
 1053: # Entry:      $spec - schema spec hashref.
 1054: # Exit:       Returns an integer scalar.
 1055: # Side effects: None.
 1056: # --------------------------------------------------
 1057: sub _rand_int {
●1058 → 1064 → 1069 1058: 	my ($self, $spec) = @_;
 1059: 
 1060: 	my $min = $spec->{min} // $INT32_MIN;
 1061: 	my $max = $spec->{max} // $INT32_MAX;
 1062: 
 1063: 	# Bias toward boundary values to probe edge conditions
 1064: 	if(rand() < $INT_BOUNDARY_RATIO) {
 1065: 		my @interesting = ($min, $min + 1, 0, -1, 1, $max - 1, $max);
 1066: 		return $interesting[ int(rand(@interesting)) ];
 1067: 	}
 1068: 
 1069: 	return $min + int(rand($max - $min + 1));

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

 1070: }
 1071: 
 1072: # --------------------------------------------------
 1073: # _rand_num
 1074: #
 1075: # Purpose:    Generate a random floating point number
 1076: #             within the spec's min/max range.

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1077: #
 1078: # Entry:      $spec - schema spec hashref.
 1079: # Exit:       Returns a numeric scalar.
 1080: # Side effects: None.
 1081: # --------------------------------------------------
 1082: sub _rand_num {
 1083: 	my ($self, $spec) = @_;
 1084: 
 1085: 	my $min = $spec->{min} // -1e9;
 1086: 	my $max = $spec->{max} //  1e9;
 1087: 
 1088: 	return $min + rand($max - $min);
 1089: }
 1090: 
 1091: # --------------------------------------------------
 1092: # _rand_string
 1093: #
 1094: # Purpose:    Generate a random string within the
 1095: #             spec's min/max length range, biased
 1096: #             toward boundary lengths.
 1097: #
 1098: # Entry:      $spec - schema spec hashref.
 1099: # Exit:       Returns a string scalar.
 1100: # Side effects: None.

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1101: #
 1102: # Notes:      Character set includes control chars
 1103: #             and NUL to probe boundary handling.
 1104: # --------------------------------------------------
 1105: sub _rand_string {
●1106 → 1113 → 1121 1106: 	my ($self, $spec) = @_;
 1107: 
 1108: 	my $min_len = $spec->{min} // 0;
 1109: 	my $max_len = $spec->{max} // $DEFAULT_MAX_STR_LEN;
 1110: 
 1111: 	# Bias toward boundary lengths at STR_BOUNDARY_RATIO frequency
 1112: 	my $len;
 1113: 	if(rand() < $STR_BOUNDARY_RATIO) {
 1114: 		my @boundary_lens = ($min_len, $min_len + 1, $max_len - 1, $max_len);
 1115: 		$len = $boundary_lens[ int(rand(@boundary_lens)) ];
 1116: 	} else {
 1117: 		$len = $min_len + int(rand($max_len - $min_len + 1));
 1118: 	}
 1119: 
 1120: 	# Clamp to non-negative
 1121: 	$len = 0 if $len < 0;
 1122: 
 1123: 	return join '', map { $RAND_CHARS[ int(rand(@RAND_CHARS)) ] } 1 .. $len;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1124: }
 1125: 
 1126: # --------------------------------------------------
 1127: # _rand_array
 1128: #
 1129: # Purpose:    Generate a random arrayref with 0 to
 1130: #             DEFAULT_MAX_ARRAY elements, each
 1131: #             generated from the items spec.
 1132: #
 1133: # Entry:      $spec - schema spec hashref.
 1134: # Exit:       Returns an arrayref.
 1135: # Side effects: None.
 1136: # --------------------------------------------------
 1137: sub _rand_array {
 1138: 	my ($self, $spec) = @_;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1139: 
 1140: 	my $items = $spec->{items} // {};
 1141: 	my $count = int(rand($DEFAULT_MAX_ARRAY + 1));
 1142: 
 1143: 	return [ map { $self->_generate_for_schema($items) } 1 .. $count ];
 1144: }
 1145: 
 1146: # --------------------------------------------------
 1147: # _rand_hash
 1148: #
 1149: # Purpose:    Generate a random hashref with values
 1150: #             generated from the properties spec.
 1151: #
 1152: # Entry:      $spec - schema spec hashref.
 1153: # Exit:       Returns a hashref.
 1154: # Side effects: None.
 1155: # --------------------------------------------------
 1156: sub _rand_hash {
●1157 → 1162 → 1166 1157: 	my ($self, $spec) = @_;
 1158: 
 1159: 	my $props = $spec->{properties} // {};

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1160: 	my %h;
 1161: 
 1162: 	for my $key (keys %{$props}) {
 1163: 		$h{$key} = $self->_generate_for_schema($props->{$key});
 1164: 	}
 1165: 
 1166: 	return \%h;
 1167: }
 1168: 
 1169: # --------------------------------------------------
 1170: # _input_is_valid
 1171: #
 1172: # Purpose:    Return true if the input satisfies all
 1173: #             constraints in the schema. Used to
 1174: #             distinguish real bugs (die on valid
 1175: #             input) from expected failures (die on
 1176: #             invalid input).
 1177: #
 1178: # Entry:      $input - the value to validate.
 1179: # Exit:       Returns 1 if valid, 0 if not.
 1180: #             Returns 1 if no schema is available.
 1181: # Side effects: None.
 1182: # --------------------------------------------------
 1183: sub _input_is_valid {
●1184 → 1193 → 1197 1184: 	my ($self, $input) = @_;
 1185: 
 1186: 	my $spec = $self->{schema}{input};
 1187: 
 1188: 	# No schema means we cannot judge validity

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

 1189: 	return 1 unless defined $spec && ref($spec);
 1190: 
 1191: 	my $input_style = $self->{schema}{input_style} // '';
 1192: 
 1193: 	if($input_style eq 'hash' || ref($input) eq 'HASH') {
 1194: 		return $self->_validate_hash_input($input, $spec);
 1195: 	}

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1196: 
 1197: 	return $self->_validate_value($input, $spec);
 1198: }
 1199: 
 1200: # --------------------------------------------------
 1201: # _validate_hash_input
 1202: #
 1203: # Purpose:    Validate a hash-style input against the

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1204: #             schema spec, checking each named field.
 1205: #
 1206: # Entry:      $input - hashref of named parameters.
 1207: #             $spec  - schema spec hashref.
 1208: # Exit:       Returns 1 if valid, 0 if not.
 1209: # Side effects: None.
 1210: # --------------------------------------------------
 1211: sub _validate_hash_input {
●1212 → 1216 → 1235 1212: 	my ($self, $input, $spec) = @_;
 1213: 
 1214: 	return 0 unless defined $input;
 1215: 
 1216: 	for my $key (keys %{$spec}) {
 1217: 		# Skip internal metadata keys
 1218: 		next if $key =~ /^_/;
 1219: 
 1220: 		my $field_spec = $spec->{$key};
 1221: 		next unless ref($field_spec) eq 'HASH';
 1222: 
 1223: 		my $value = ref($input) eq 'HASH' ? $input->{$key} : undef;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1224: 
 1225: 		# Required field missing is always invalid
 1226: 		if(!defined($value) && !$field_spec->{optional}) {
 1227: 			return 0;
 1228: 		}

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1229: 
 1230: 		next unless defined $value;
 1231: 
 1232: 		return 0 unless $self->_validate_value($value, $field_spec);
 1233: 	}
 1234: 
 1235: 	return 1;
 1236: }
 1237: 
 1238: # --------------------------------------------------
 1239: # _validate_value
 1240: #
 1241: # Purpose:    Validate a single value against a schema
 1242: #             type spec, checking type and constraints.
 1243: #
 1244: # Entry:      $value - the value to validate.
 1245: #             $spec  - schema spec hashref.
 1246: # Exit:       Returns 1 if valid, 0 if not.
 1247: # Side effects: None.
 1248: #
 1249: # Notes:      Number validation accepts both integer
 1250: #             and floating point forms including
 1251: #             scientific notation. Type mismatch
 1252: #             always returns 0.
 1253: # --------------------------------------------------
 1254: sub _validate_value {
●1255 → 1262 → 1306 1255: 	my ($self, $value, $spec) = @_;
 1256: 
 1257: 	# Undef is never valid unless optional — caller already checked optional
 1258: 	return 0 unless defined $value;
 1259: 
 1260: 	my $type = $spec->{type} // $TYPE_STRING;
 1261: 
 1262: 	if($type eq $TYPE_INTEGER) {
 1263: 		return 0 unless $value =~ /^-?\d+$/;
 1264: 		return 0 if defined($spec->{min}) && $value < $spec->{min};
 1265: 		return 0 if defined($spec->{max}) && $value > $spec->{max};
 1266: 	}
 1267: 	elsif($type eq $TYPE_NUMBER) {
 1268: 		# Accept integers, decimals, and scientific notation
 1269: 		return 0 unless $value =~ /^-?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?$/;
 1270: 		return 0 if defined($spec->{min}) && $value < $spec->{min};
 1271: 		return 0 if defined($spec->{max}) && $value > $spec->{max};
 1272: 	}
 1273: 	elsif($type eq $TYPE_STRING) {
 1274: 		my $len = length($value);
 1275: 		return 0 if defined($spec->{min}) && $len < $spec->{min};
 1276: 		return 0 if defined($spec->{max}) && $len > $spec->{max};
 1277: 		if(defined($spec->{matches})) {
 1278: 			(my $pat = $spec->{matches}) =~ s{^/(.+)/$}{$1};
 1279: 
 1280: 			# ReDoS guard: a schema-supplied pattern matched against
 1281: 			# fuzzer-generated (attacker-shaped) input could exhibit
 1282: 			# catastrophic backtracking. Bound the match with alarm()
 1283: 			# the same way target_sub calls are bounded elsewhere in
 1284: 			# this module, and treat a timeout as a non-match.
 1285: 			my $matched = eval {
 1286: 				local $SIG{ALRM} = sub { die "matches regex timed out\n" };
 1287: 				alarm($MATCHES_REGEX_TIMEOUT_SECS);
 1288: 				my $m = $value =~ /$pat/;
 1289: 				alarm(0);
 1290: 				$m;
 1291: 			};
 1292: 			alarm(0);
 1293: 			return 0 unless $matched;
 1294: 		}
 1295: 	}
 1296: 	elsif($type eq $TYPE_BOOLEAN) {
 1297: 		return 0 unless $value =~ /^[01]$/;
 1298: 	}
 1299: 	elsif($type eq $TYPE_ARRAY || $type eq 'array') {
 1300: 		return 0 unless ref($value) eq 'ARRAY';
 1301: 	}
 1302: 	elsif($type eq $TYPE_HASH || $type eq 'hash') {
 1303: 		return 0 unless ref($value) eq 'HASH';
 1304: 	}
 1305: 
 1306: 	return 1;
 1307: }
 1308: 
 1309: # --------------------------------------------------
 1310: # _mutate
 1311: #
 1312: # Purpose:    Apply a random mutation to an input
 1313: #             value, dispatching on its type.
 1314: #
 1315: # Entry:      $input - the value to mutate.
 1316: # Exit:       Returns a mutated copy of the input.
 1317: # Side effects: None.
 1318: #
 1319: # Notes:      Blessed references are passed through
 1320: #             unchanged. Undef is replaced with a
 1321: #             freshly generated random value.
 1322: # --------------------------------------------------
 1323: sub _mutate {
●1324 → 1328 → 1350 1324: 	my ($self, $input) = @_;
 1325: 
 1326: 	my $type = ref($input);
 1327: 
 1328: 	if(!defined $input) {
 1329: 		# Replace undef with a fresh random value
 1330: 		return $self->_generate_random();
 1331: 	}
 1332: 	elsif(!$type) {
 1333: 		# Dispatch scalar mutation based on apparent type
 1334: 		if($input =~ /^-?\d+$/) {
 1335: 			return $self->_mutate_int($input);
 1336: 		} elsif($input =~ /^-?[\d.]+$/) {
 1337: 			return $self->_mutate_num($input);
 1338: 		} else {
 1339: 			return $self->_mutate_string($input);
 1340: 		}
 1341: 	}
 1342: 	elsif($type eq 'ARRAY') {
 1343: 		return $self->_mutate_array($input);
 1344: 	}
 1345: 	elsif($type eq 'HASH') {
 1346: 		return $self->_mutate_hash($input);
 1347: 	}
 1348: 
 1349: 	# Blessed refs and other types pass through unchanged
 1350: 	return $input;
 1351: }
 1352: 
 1353: # --------------------------------------------------
 1354: # _mutate_int
 1355: #
 1356: # Purpose:    Apply a random arithmetic mutation to
 1357: #             an integer value.
 1358: #
 1359: # Entry:      $n - the integer to mutate.
 1360: # Exit:       Returns a mutated integer.
 1361: # Side effects: None.
 1362: # --------------------------------------------------
 1363: sub _mutate_int {
 1364: 	my ($self, $n) = @_;
 1365: 	my $op = int(rand(8));
 1366: 	return $n + 1                      if $op == 0;
 1367: 	return $n - 1                      if $op == 1;
 1368: 	return $n * 2                      if $op == 2;
 1369: 	return $n == 0 ? 1 : int($n / 2)  if $op == 3;
 1370: 	return -$n                         if $op == 4;
 1371: 	return 0                           if $op == 5;
 1372: 	return $INT32_MAX                  if $op == 6;
 1373: 	return $INT32_MIN;
 1374: }
 1375: 
 1376: # --------------------------------------------------
 1377: # _mutate_num
 1378: #
 1379: # Purpose:    Apply a random arithmetic mutation to
 1380: #             a floating point value.
 1381: #
 1382: # Entry:      $n - the number to mutate.
 1383: # Exit:       Returns a mutated number.
 1384: # Side effects: None.
 1385: # --------------------------------------------------
 1386: sub _mutate_num {
 1387: 	my ($self, $n) = @_;
 1388: 	my $op = int(rand(5));
 1389: 	return $n + rand(10)      if $op == 0;
 1390: 	return $n - rand(10)      if $op == 1;
 1391: 	return $n * (1 + rand())  if $op == 2;
 1392: 	return 0                  if $op == 3;
 1393: 	return -$n;
 1394: }
 1395: 
 1396: # --------------------------------------------------
 1397: # _mutate_string
 1398: #
 1399: # Purpose:    Apply a random structural mutation to
 1400: #             a string value — bit flip, insert,
 1401: #             delete, truncate, repeat, or replace
 1402: #             with an interesting known value.
 1403: #
 1404: # Entry:      $s - the string to mutate.
 1405: # Exit:       Returns a mutated string.
 1406: # Side effects: None.
 1407: # --------------------------------------------------
 1408: sub _mutate_string {
 1409: 	my ($self, $s) = @_;
 1410: 
 1411: 	my $len = length($s);
 1412: 
 1413: 	my @ops = (
 1414: 		# Bit flip a random character
 1415: 		sub {
 1416: 			return $s unless $len;
 1417: 			my $pos  = int(rand($len));
 1418: 			my $char = substr($s, $pos, 1);
 1419: 			substr($s, $pos, 1) = chr(ord($char) ^ (1 << int(rand(8))));
 1420: 			$s
 1421: 		},
 1422: 		# Insert a random byte
 1423: 		sub {
 1424: 			my $pos  = int(rand($len + 1));
 1425: 			my $char = chr(int(rand(256)));
 1426: 			substr($s, $pos, 0, $char);
 1427: 			$s
 1428: 		},
 1429: 		# Delete a random character
 1430: 		sub {
 1431: 			return $s unless $len;
 1432: 			substr($s, int(rand($len)), 1, '');
 1433: 			$s
 1434: 		},
 1435: 		# Truncate at a random position
 1436: 		sub { substr($s, 0, int(rand($len + 1))) },
 1437: 		# Double the string
 1438: 		sub { $s x 2 },
 1439: 		# Replace with a known interesting string
 1440: 		sub { $INTERESTING_STRINGS[ int(rand(@INTERESTING_STRINGS)) ] },
 1441: 	);
 1442: 
 1443: 	return $ops[ int(rand(@ops)) ]->();
 1444: }
 1445: 
 1446: # --------------------------------------------------
 1447: # _mutate_array
 1448: #
 1449: # Purpose:    Apply a random structural mutation to
 1450: #             an arrayref — mutate element, duplicate,
 1451: #             delete, or empty.
 1452: #
 1453: # Entry:      $arr - the arrayref to mutate.
 1454: # Exit:       Returns a mutated arrayref copy.
 1455: # Side effects: None.
 1456: # --------------------------------------------------
 1457: sub _mutate_array {
 1458: 	my ($self, $arr) = @_;
 1459: 
 1460: 	my @copy = @{$arr};
 1461: 
 1462: 	my @ops = (
 1463: 		# Mutate a random element
 1464: 		sub {
 1465: 			return [] unless @copy;
 1466: 			my $i = int(rand(@copy));
 1467: 			$copy[$i] = $self->_mutate($copy[$i]);
 1468: 			\@copy
 1469: 		},
 1470: 		# Duplicate a random element
 1471: 		sub {
 1472: 			return \@copy unless @copy;
 1473: 			my $i = int(rand(@copy));
 1474: 			splice @copy, $i, 0, $copy[$i];
 1475: 			\@copy
 1476: 		},
 1477: 		# Delete a random element
 1478: 		sub {
 1479: 			return \@copy unless @copy;
 1480: 			splice @copy, int(rand(@copy)), 1;
 1481: 			\@copy
 1482: 		},
 1483: 		# Return empty array
 1484: 		sub { [] },
 1485: 	);
 1486: 
 1487: 	return $ops[ int(rand(@ops)) ]->();
 1488: }
 1489: 
 1490: # --------------------------------------------------
 1491: # _mutate_hash
 1492: #
 1493: # Purpose:    Apply a random mutation to one value
 1494: #             in a hashref copy.
 1495: #
 1496: # Entry:      $h - the hashref to mutate.
 1497: # Exit:       Returns a mutated hashref copy.
 1498: # Side effects: None.
 1499: # --------------------------------------------------
 1500: sub _mutate_hash {
 1501: 	my ($self, $h) = @_;
 1502: 
 1503: 	my %copy = %{$h};
 1504: 	my @keys = keys %copy;
 1505: 
 1506: 	# Return unchanged if hash is empty
 1507: 	return \%copy unless @keys;
 1508: 
 1509: 	my $k = $keys[ int(rand(@keys)) ];
 1510: 	$copy{$k} = $self->_mutate($copy{$k});
 1511: 
 1512: 	return \%copy;
 1513: }
 1514: 
 1515: # --------------------------------------------------
 1516: # _seed_corpus
 1517: #
 1518: # Purpose:    Pre-populate the corpus with a small
 1519: #             set of randomly generated inputs to
 1520: #             give the fuzzing loop a starting point.
 1521: #
 1522: # Entry:      None beyond $self.
 1523: # Exit:       Returns nothing. Appends to $self->{corpus}.
 1524: # Side effects: Modifies $self->{corpus}.
 1525: # --------------------------------------------------
 1526: sub _seed_corpus {
●1527 → 1529 → 0 1527: 	my $self = $_[0];
 1528: 
 1529: 	for (1 .. $SEED_CORPUS_SIZE) {
 1530: 		push @{ $self->{corpus} }, {
 1531: 			input    => $self->_generate_random(),
 1532: 			coverage => {},
 1533: 		};
 1534: 	}
 1535: }
 1536: 
 1537: # --------------------------------------------------
 1538: # _build_report
 1539: #
 1540: # Purpose:    Construct the summary report hashref
 1541: #             returned by run().
 1542: #
 1543: # Entry:      None beyond $self.
 1544: # Exit:       Returns a report hashref.
 1545: # Side effects: None.
 1546: # --------------------------------------------------
 1547: sub _build_report {
 1548: 	my $self = $_[0];
 1549: 
 1550: 	return {
 1551: 		total_iterations   => $self->{stats}{total},
 1552: 		interesting_inputs => $self->{stats}{interesting},
 1553: 		corpus_size        => scalar @{ $self->{corpus} },
 1554: 		branches_covered   => $self->{stats}{coverage},
 1555: 		bugs_found         => $self->{stats}{bugs},
 1556: 		bugs               => $self->{bugs},
 1557: 	};
 1558: }
 1559: 
 1560: =head1 COMMON PITFALLS
 1561: 
 1562: =over 4
 1563: 
 1564: =item Forgetting that C<load_corpus> does not restore bugs
 1565: 
 1566: The JSON written by C<save_corpus> contains a C<bugs> array, but C<load_corpus>
 1567: reads only the C<corpus> key.  A freshly loaded fuzzer always starts with an
 1568: empty bugs list.  If you need to carry bugs across sessions, persist them
 1569: separately.
 1570: 
 1571: =item Assuming coverage guidance is always active
 1572: 
 1573: If C<Devel::Cover> is not installed, the fuzzer falls back to random-only mode
 1574: and emits a warning.  Corpus entries in this mode have C<coverage =E<gt> {}>
 1575: and are kept using the C<RANDOM_KEEP_RATIO> (20%) heuristic rather than branch
 1576: novelty.  Install C<Devel::Cover> (or C<cpanm --with-recommends
 1577: App::Test::Generator>) for full coverage-guided behaviour.
 1578: 
 1579: =item Using C<refaddr> on C<corpus()> after C<minimize_corpus>
 1580: 
 1581: C<minimize_corpus> replaces C<$self-E<gt>{corpus}> with a B<new> arrayref.
 1582: Any caller that holds a reference to the old arrayref (e.g. from a prior
 1583: C<corpus()> call) will see a stale snapshot.  Always call C<corpus()> after
 1584: C<minimize_corpus> if you need the current list.
 1585: 
 1586: =item Setting C<timeout =E<gt> 0> on blocking targets
 1587: 
 1588: Setting C<timeout> to 0 disables the per-call C<alarm()>.  This is correct for
 1589: targets that legitimately block (e.g. sleeping, waiting on I/O), but means a
 1590: hung target_sub will hang the whole fuzzing run indefinitely.  Use a
 1591: process-level timeout (e.g. C<Sys::AlarmCall>) if you need a safety net for
 1592: blocking code.
 1593: 
 1594: =back
 1595: 
 1596: =head1 LIMITATIONS
 1597: 
 1598: =over 4
 1599: 
 1600: =item Single-threaded
 1601: 
 1602: All fuzzing iterations run sequentially in the calling process.  For large
 1603: iteration counts, wall-clock time scales linearly.  Parallelism requires
 1604: splitting the iteration budget across multiple fuzzer instances and merging
 1605: their corpora.
 1606: 
 1607: =item Coverage granularity is branch-level
 1608: 
 1609: Branch coverage is the finest granularity Devel::Cover exposes via its public
 1610: API.  Path coverage (distinct sequences of branches) is not tracked — two
 1611: inputs that cover the same branches but exercise different call orders are
 1612: treated as equivalent.
 1613: 
 1614: =item No inter-run learning without save/load
 1615: 
 1616: The corpus is entirely in memory.  To carry learning across separate
 1617: invocations, call C<save_corpus> at the end and C<load_corpus> at the start of
 1618: each subsequent run.
 1619: 
 1620: =back
 1621: 
 1622: =head1 SEE ALSO
 1623: 
 1624: =over 4
 1625: 
 1626: =item L<Devel::Cover>
 1627: 
 1628: =item L<App::Test::Generator>
 1629: 
 1630: =item C<bin/extract-schemas> (the C<--minimize-corpus> flag)
 1631: 
 1632: =back
 1633: 
 1634: =head1 AUTHOR
 1635: 
 1636: Nigel Horne, C<< <njh at nigelhorne.com> >>
 1637: 
 1638: Portions of this module's initial design and documentation were created
 1639: with the assistance of AI.
 1640: 
 1641: =head1 LICENCE AND COPYRIGHT
 1642: 
 1643: Copyright 2026 Nigel Horne.
 1644: 
 1645: Usage is subject to GPL2 licence terms.
 1646: If you use it,
 1647: please let me know.
 1648: 
 1649: =cut
 1650: 
 1651: 1;