lib/App/Test/Generator/CoverageGuidedFuzzer.pm

⬅ Previous Index Next ➡
Structural Coverage (Approximate)

TER1 (Statement): 91.13%
TER2 (Branch): 79.07%
TER3 (LCSAJ): 100.0% (19/19)
Approximate LCSAJ segments: 173

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: # Type name constants — used in schema dispatch
   28: # --------------------------------------------------
   29: Readonly my $TYPE_INTEGER => 'integer';
   30: Readonly my $TYPE_NUMBER  => 'number';
   31: Readonly my $TYPE_BOOLEAN => 'boolean';
   32: Readonly my $TYPE_ARRAY   => 'arrayref';
   33: Readonly my $TYPE_HASH    => 'hashref';
   34: Readonly my $TYPE_STRING  => 'string';
   35: 
   36: # --------------------------------------------------
   37: # JSON module preference order
   38: # --------------------------------------------------
   39: Readonly my @JSON_MODULES => qw(JSON::MaybeXS JSON);
   40: 
   41: our $VERSION = '0.41';
   42: 
   43: =head1 NAME
   44: 
   45: App::Test::Generator::CoverageGuidedFuzzer - AFL-style coverage-guided fuzzing for App::Test::Generator
   46: 
   47: =head1 VERSION
   48: 
   49: Version 0.41
   50: 
   51: =head1 SYNOPSIS
   52: 
   53:     use App::Test::Generator::CoverageGuidedFuzzer;
   54: 
   55:     my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
   56:         schema     => $yaml_schema,
   57:         target_sub => \&My::Module::validate,
   58:         iterations => 200,
   59:         seed       => 42,
   60:     );
   61: 
   62:     my $report = $fuzzer->run();
   63:     $fuzzer->save_corpus('t/corpus/validate.json');
   64: 
   65: =head1 DESCRIPTION
   66: 
   67: Implements coverage-guided fuzzing on top of App::Test::Generator's
   68: existing schema-driven input generation. Instead of purely random
   69: generation it:
   70: 
   71: =over 4
   72: 
   73: =item 1. Generates or mutates a structured input
   74: 
   75: =item 2. Runs the target sub under Devel::Cover to capture branch hits
   76: 
   77: =item 3. Keeps inputs that discover new branches in a corpus
   78: 
   79: =item 4. Preferentially mutates corpus entries in future iterations
   80: 
   81: =back
   82: 
   83: This is the Perl equivalent of what AFL/libFuzzer do at the byte level,
   84: but operating on typed, schema-validated Perl data structures.
   85: 
   86: =head1 METHODS
   87: 
   88: =head2 new
   89: 
   90: Construct a new coverage-guided fuzzer.
   91: 
   92:     my $fuzzer = App::Test::Generator::CoverageGuidedFuzzer->new(
   93:         schema     => $yaml_schema,
   94:         target_sub => \&My::Module::validate,
   95:         iterations => 200,
   96:         seed       => 42,
   97:         instance   => $obj,   # optional pre-built object for method calls
   98:     );
   99: 
  100: =head3 Arguments
  101: 
  102: =over 4
  103: 
  104: =item * C<schema>
  105: 
  106: A hashref representing the parsed YAML schema for the target function.
  107: Required.
  108: 
  109: =item * C<target_sub>
  110: 
  111: A CODE reference to the function under test. Required.
  112: 
  113: =item * C<iterations>
  114: 
  115: Number of fuzzing iterations to run. Optional - defaults to 100.
  116: 
  117: =item * C<seed>
  118: 
  119: Random seed for reproducible runs. Optional - defaults to C<time()>.
  120: 
  121: =item * C<instance>
  122: 
  123: An optional pre-built object to use as the invocant when calling the
  124: target sub as a method.
  125: 
  126: =item * C<timeout>
  127: 
  128: Seconds to allow each C<target_sub> call before it is aborted via
  129: C<alarm()> and recorded as a bug. Optional - defaults to 5. Set to 0
  130: to disable the timeout (e.g. for target subs that legitimately block).
  131: 
  132: =back
  133: 
  134: =head3 Returns
  135: 
  136: A blessed hashref. Croaks if C<schema> or C<target_sub> is missing.
  137: 
  138: =head3 API specification
  139: 
  140: =head4 input
  141: 
  142:     {
  143:         schema     => { type => HASHREF },
  144:         target_sub => { type => CODEREF },
  145:         iterations => { type => SCALAR,  optional => 1 },
  146:         seed       => { type => SCALAR,  optional => 1 },
  147:         instance   => { type => OBJECT,  optional => 1 },
  148:         timeout    => { type => SCALAR,  optional => 1 },
  149:     }
  150: 
  151: =head4 output
  152: 
  153:     {
  154:         type => OBJECT,
  155:         isa  => 'App::Test::Generator::CoverageGuidedFuzzer',
  156:     }
  157: 
  158: =cut
  159: 
  160: sub new {
●161 → 192 → 196  161: 	my ($class, %args) = @_;
  162: 
  163: 	croak 'schema required'     unless $args{schema};
  164: 	croak 'target_sub required' unless $args{target_sub};
  165: 
  166: 	my $self = bless {
  167: 		schema     => $args{schema},
  168: 		target_sub => $args{target_sub},
  169: 		instance   => $args{instance},
  170: 		iterations => $args{iterations} // $DEFAULT_ITERATIONS,
  171: 		seed       => $args{seed}       // time(),
  172: 		timeout    => $args{timeout}    // $DEFAULT_TIMEOUT_SECS,
  173: 		corpus     => [],   # [{input => ..., coverage => {...}}]
  174: 		covered    => {},   # "file:line:branch" => 1
  175: 		bugs       => [],   # [{input => ..., error => ...}]
  176: 		stats      => {
  177: 			total       => 0,
  178: 			interesting => 0,
  179: 			bugs        => 0,
  180: 			coverage    => 0,
  181: 		},
  182: 		_cover_available => undef,
  183: 	}, $class;
  184: 
  185: 	srand($self->{seed});
  186: 
  187: 	# Probe for Devel::Cover availability once at construction time
  188: 	$self->{_cover_available} = eval { require Devel::Cover; 1 } ? 1 : 0;
  189: 
  190: 	# Warn once per process if coverage guidance is unavailable
  191: 	state $cover_warned = 0;
  192: 	if(!$self->{_cover_available} && !$cover_warned++) {

					

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

  193: 		warn 'Devel::Cover not available; fuzzing without coverage guidance.';
  194: 	}
  195: 
  196: 	return $self;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  197: }
  198: 
  199: =head2 run
  200: 
  201: Run the coverage-guided fuzzing loop and return a summary report.
  202: 
  203:     my $report = $fuzzer->run();
  204:     printf "Branches covered: %d\n", $report->{branches_covered};
  205:     printf "Bugs found:       %d\n", $report->{bugs_found};
  206: 
  207: =head3 Arguments
  208: 
  209: None beyond C<$self>.
  210: 
  211: =head3 Returns
  212: 
  213: A hashref with keys C<total_iterations>, C<interesting_inputs>,
  214: C<corpus_size>, C<branches_covered>, C<bugs_found>, and C<bugs>.
  215: 
  216: =head3 Notes
  217: 
  218: A C<target_sub> call that dies is only recorded in C<bugs> when the
  219: input that triggered it is valid per C<schema>. A die triggered by an
  220: input the schema itself marks invalid (e.g. out of the declared
  221: C<min>/C<max> range) is expected behaviour, not a bug, and is silently
  222: discarded.
  223: 
  224: =head3 API specification
  225: 
  226: =head4 input
  227: 
  228:     {
  229:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  230:     }
  231: 
  232: =head4 output
  233: 
  234:     {
  235:         type => HASHREF,
  236:         keys => {
  237:             total_iterations   => { type => SCALAR  },
  238:             interesting_inputs => { type => SCALAR  },
  239:             corpus_size        => { type => SCALAR  },
  240:             branches_covered   => { type => SCALAR  },
  241:             bugs_found         => { type => SCALAR  },
  242:             bugs               => { type => ARRAYREF },
  243:         },
  244:     }
  245: 
  246: =cut
  247: 
  248: sub run {
●249 → 255 → 271  249: 	my ($self) = @_;
  250: 
  251: 	# Phase 1: seed the corpus with a small set of random inputs
  252: 	$self->_seed_corpus();
  253: 
  254: 	# Phase 2: main fuzzing loop — alternate between mutation and exploration
  255: 	for my $i (1 .. $self->{iterations}) {
  256: 		my $input;
  257: 
  258: 		if(@{ $self->{corpus} } && rand() < $CORPUS_MUTATE_RATIO) {

					

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

  259: 			# Mutate a randomly chosen corpus entry
  260: 			my $parent = $self->{corpus}[ int(rand(@{ $self->{corpus} })) ];
  261: 			$input = $self->_mutate($parent->{input});
  262: 		} else {
  263: 			# Fresh random generation for exploration
  264: 			$input = $self->_generate_random();
  265: 		}
  266: 
  267: 		$self->_run_one($input);
  268: 		$self->{stats}{total}++;
  269: 	}
  270: 
  271: 	$self->{stats}{coverage} = scalar keys %{ $self->{covered} };
  272: 	return $self->_build_report();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  273: }
  274: 
  275: =head2 corpus
  276: 
  277: Return the accumulated corpus as an arrayref of hashrefs with keys
  278: C<input> and C<coverage>.
  279: 
  280:     my $corpus = $fuzzer->corpus();
  281: 
  282: =head3 API specification
  283: 
  284: =head4 input
  285: 
  286:     { self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' } }
  287: 
  288: =head4 output
  289: 
  290:     { type => ARRAYREF }
  291: 
  292: =cut
  293: 
  294: sub corpus { $_[0]->{corpus} }
  295: 
  296: =head2 bugs
  297: 
  298: Return bugs found as an arrayref of hashrefs with keys C<input> and
  299: C<error>.
  300: 
  301:     my $bugs = $fuzzer->bugs();
  302: 
  303: =head3 API specification
  304: 
  305: =head4 input
  306: 
  307:     { self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' } }
  308: 
  309: =head4 output
  310: 
  311:     { type => ARRAYREF }
  312: 
  313: =cut
  314: 
  315: sub bugs { $_[0]->{bugs} }
  316: 
  317: =head2 save_corpus
  318: 
  319: Serialise the corpus to a JSON file for replay or extension on future
  320: runs.
  321: 
  322:     $fuzzer->save_corpus('t/corpus/validate.json');
  323: 
  324: =head3 Arguments
  325: 
  326: =over 4
  327: 
  328: =item * C<$path>
  329: 
  330: Path to write the JSON corpus file. Required.
  331: 
  332: =back
  333: 
  334: =head3 Returns
  335: 
  336: Nothing. Croaks if the file cannot be written or no JSON module is
  337: available.
  338: 
  339: =head3 Side effects
  340: 
  341: Writes a JSON file to C<$path>.
  342: 
  343: =head3 API specification
  344: 
  345: =head4 input
  346: 
  347:     {
  348:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  349:         path => { type => SCALAR },
  350:     }
  351: 
  352: =head4 output
  353: 
  354:     { type => UNDEF }
  355: 
  356: =cut
  357: 
  358: sub save_corpus {
  359: 	my ($self, $path) = @_;
  360: 
  361: 	croak 'path required' unless defined $path;
  362: 
  363: 	my $json = _load_json_module();
  364: 
  365: 	open my $fh, '>', $path
  366: 		or croak "Cannot write corpus to $path: $!";
  367: 
  368: 	print $fh $json->new->pretty->encode({
  369: 		seed   => $self->{seed},
  370: 		corpus => [ map { { input => $_->{input} } } @{ $self->{corpus} } ],
  371: 		bugs   => $self->{bugs},
  372: 	});
  373: 
  374: 	close $fh;
  375: }
  376: 
  377: =head2 load_corpus
  378: 
  379: Load a previously saved corpus JSON file, pre-seeding the fuzzer so
  380: it continues from where it left off.
  381: 
  382:     $fuzzer->load_corpus('t/corpus/validate.json');
  383: 
  384: =head3 Arguments
  385: 
  386: =over 4
  387: 
  388: =item * C<$path>
  389: 
  390: Path to the JSON corpus file to load. Required.
  391: 
  392: =back
  393: 
  394: =head3 Returns
  395: 
  396: Nothing. Croaks if the file cannot be read or no JSON module is
  397: available.
  398: 
  399: =head3 Side effects
  400: 
  401: Appends loaded entries to C<< $self->{corpus} >>.
  402: 
  403: =head3 API specification
  404: 
  405: =head4 input
  406: 
  407:     {
  408:         self => { type => OBJECT, isa => 'App::Test::Generator::CoverageGuidedFuzzer' },
  409:         path => { type => SCALAR },
  410:     }
  411: 
  412: =head4 output
  413: 
  414:     { type => UNDEF }
  415: 
  416: =cut
  417: 
  418: sub load_corpus {
●419 → 433 → 0  419: 	my ($self, $path) = @_;
  420: 
  421: 	croak 'path required' unless defined $path;
  422: 
  423: 	my $json = _load_json_module();
  424: 
  425: 	open my $fh, '<', $path
  426: 		or croak "Cannot read corpus from $path: $!";
  427: 
  428: 	my $data = $json->new->decode(do { local $/; <$fh> });
  429: 	close $fh;
  430: 
  431: 	# Load corpus entries with empty coverage — coverage state from a
  432: 	# previous process cannot be restored, only the inputs themselves
  433: 	for my $entry (@{ $data->{corpus} // [] }) {
  434: 		push @{ $self->{corpus} }, {
  435: 			input    => $entry->{input},
  436: 			coverage => {},
  437: 		};
  438: 	}
  439: }
  440: 
  441: # --------------------------------------------------
  442: # _load_json_module
  443: #
  444: # Find and load the first available JSON
  445: #     module from the preference list.
  446: #
  447: # Entry:      None.
  448: # Exit:       Returns the name of the loaded module.
  449: #             Croaks if none are available.
  450: #
  451: # Side effects: Loads a JSON module into the process.
  452: #
  453: # Notes:      Uses explicit require rather than string
  454: #             eval for safety. JSON::MaybeXS is
  455: #             preferred over JSON.
  456: # --------------------------------------------------
  457: sub _load_json_module {
●458 → 458 → 466  458: 	for my $mod (@JSON_MODULES) {
  459: 		# Convert package name to file path — require $var does not
  460: 		# do the :: -> / conversion that bareword require does
  461: 		(my $file = $mod) =~ s{::}{/}g;
  462: 		$file .= '.pm';
  463: 		my $ok = eval { require $file; 1 };
  464: 		return $mod if $ok;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  465: 	}
  466: 	croak 'No JSON module available; install JSON or JSON::MaybeXS';
  467: }
  468: 
  469: # --------------------------------------------------
  470: # _run_one
  471: #
  472: # Run the target sub with a single input,
  473: #     record coverage, detect bugs, and update
  474: #     the corpus if the input is interesting.
  475: #
  476: # Entry:      $input - the value to pass to target_sub.
  477: #
  478: # Exit:       Returns nothing. Updates $self->{corpus},
  479: #             $self->{bugs}, and $self->{covered}.
  480: #
  481: # Side effects: Calls target_sub. May update corpus
  482: #               and covered hashes.
  483: #
  484: # Notes:      When Devel::Cover is available, coverage
  485: #             is captured via _run_with_cover.
  486: #             Unexpected warnings are treated as soft
  487: #             bugs if they match known warning patterns.
  488: # --------------------------------------------------
  489: sub _run_one {
●490 → 494 → 528  490: 	my ($self, $input) = @_;
  491: 
  492: 	my ($result, $error, $coverage);
  493: 
  494: 	if($self->{_cover_available}) {

					

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

  495: 		$coverage = $self->_run_with_cover($input, \$result, \$error);
  496: 	} else {
  497: 		$coverage = {};
  498: 
  499: 		# Include instance as invocant for method calls
  500: 		my @call_args = defined($self->{instance})
  501: 			? ($self->{instance}, $input)
  502: 			: ($input);
  503: 
  504: 		my @warnings;
  505: 		eval {
  506: 			local $SIG{__WARN__} = sub { push @warnings, @_ };
  507: 			local $SIG{__DIE__};
  508: 			# A hanging target_sub call would otherwise hang the
  509: 			# whole fuzzing run — alarm() bounds it and surfaces
  510: 			# the timeout as a recorded bug instead.
  511: 			local $SIG{ALRM} = sub { die "target_sub timed out after $self->{timeout}s\n" };
  512: 			alarm($self->{timeout}) if $self->{timeout};
  513: 			$result = $self->{target_sub}->(@call_args);
  514: 		};
  515: 		alarm(0) if $self->{timeout};
  516: 		$error = $@ if $@;
  517: 
  518: 		# Treat unexpected warnings matching known bad patterns as soft bugs
  519: 		if(!defined($error) && @warnings) {

					

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

  520: 			my $w = join '', @warnings;
  521: 			$error = "warning: $w"
  522: 				if $w =~ /uninitialized|undefined|blessed|invalid/i;
  523: 		}
  524: 	}
  525: 
  526: 	# Record bugs — only when the input was valid per the schema.
  527: 	# A die on invalid input is correct behaviour, not a bug.
●528 → 528 → 534  528: 	if($error && $self->_input_is_valid($input)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  529: 		push @{ $self->{bugs} }, { input => $input, error => "$error" };
  530: 		$self->{stats}{bugs}++;
  531: 	}
  532: 
  533: 	# Keep the input in the corpus if it exercised new branches
●534 → 534 → 0  534: 	if($self->_is_interesting($coverage)) {

					

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

  535: 		push @{ $self->{corpus} }, { input => $input, coverage => $coverage };
  536: 		$self->_update_covered($coverage);
  537: 		$self->{stats}{interesting}++;
  538: 	}
  539: }
  540: 
  541: # --------------------------------------------------
  542: # _run_with_cover
  543: #
  544: # Purpose:    Run the target sub with Devel::Cover
  545: #             active and return the set of newly hit
  546: #             branches as a hashref.
  547: #
  548: # Entry:      $input      - value to pass to target_sub.
  549: #             $result_ref - scalar ref to store result.
  550: #             $error_ref  - scalar ref to store error.
  551: #
  552: # Exit:       Returns a hashref of newly hit branch
  553: #             keys ("file:line:branch").
  554: #
  555: # Side effects: Calls Devel::Cover::start/stop.
  556: #               Sets $$result_ref and $$error_ref.
  557: #
  558: # Notes:      Snapshot comparison is imprecise for
  559: #             concurrent use but correct for single-
  560: #             threaded fuzzing. Instance is passed
  561: #             as invocant when set. Devel::Cover state
  562: #             only grows, so this iteration's "before"
  563: #             is exactly the previous iteration's
  564: #             "after" -- cached in $self to avoid two
  565: #             full Devel::Cover walks per iteration.
  566: # --------------------------------------------------
  567: sub _run_with_cover {
●568 → 596 → 600  568: 	my ($self, $input, $result_ref, $error_ref) = @_;
  569: 
  570: 	Devel::Cover::start() if Devel::Cover->can('start');
  571: 
  572: 	my %before = %{ $self->{_last_cover_snapshot} || {} };
  573: 
  574: 	# Include instance as invocant for method calls
  575: 	my @call_args = defined($self->{instance})
  576: 		? ($self->{instance}, $input)
  577: 		: ($input);
  578: 
  579: 	eval {
  580: 		local $SIG{__DIE__};
  581: 		# See _run_one() — bound the call so a hanging target_sub
  582: 		# cannot hang the whole fuzzing run.
  583: 		local $SIG{ALRM} = sub { die "target_sub timed out after $self->{timeout}s\n" };
  584: 		alarm($self->{timeout}) if $self->{timeout};
  585: 		$$result_ref = $self->{target_sub}->(@call_args);
  586: 	};
  587: 	alarm(0) if $self->{timeout};
  588: 	$$error_ref = $@ if $@;
  589: 
  590: 	my %after = $self->_snapshot_cover();
  591: 	$self->{_last_cover_snapshot} = { %after };
  592: 	Devel::Cover::stop() if Devel::Cover->can('stop');
  593: 
  594: 	# Return only branches newly hit in this call
  595: 	my %delta;
  596: 	for my $key (keys %after) {
  597: 		$delta{$key} = 1 unless exists $before{$key};
  598: 	}
  599: 
  600: 	return \%delta;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  601: }
  602: 
  603: # --------------------------------------------------
  604: # _snapshot_cover
  605: #
  606: # Purpose:    Take a lightweight snapshot of the
  607: #             currently hit branches from Devel::Cover.
  608: #
  609: # Entry:      None beyond $self.
  610: # Exit:       Returns a hash of "file:line:branch" keys.
  611: #
  612: # Side effects: Reads Devel::Cover internal state.
  613: #
  614: # Notes:      Falls back to empty hash if the
  615: #             Devel::Cover API is not accessible.
  616: #             All errors are silently swallowed since
  617: #             coverage is best-effort.
  618: # --------------------------------------------------
  619: sub _snapshot_cover {
  620: 	my ($self) = @_;
  621: 	my %snap;
  622: 
  623: 	eval {
  624: 		my $cover = Devel::Cover::get_coverage();
  625: 		return unless $cover;
  626: 
  627: 		for my $file (keys %{$cover}) {
  628: 			my $branch = $cover->{$file}{branch} or next;
  629: 			for my $line (keys %{$branch}) {
  630: 				for my $b (0 .. $#{ $branch->{$line} }) {
  631: 					$snap{"$file:$line:$b"} = 1
  632: 						if $branch->{$line}[$b];
  633: 				}
  634: 			}
  635: 		}
  636: 	};
  637: 
  638: 	return %snap;

					

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

  639: }
  640: 
  641: # --------------------------------------------------
  642: # _is_interesting
  643: #
  644: # Purpose:    Return true if the coverage hashref
  645: #             contains any branch not yet in the
  646: #             global covered set.
  647: #
  648: # Entry:      $coverage - hashref of branch keys.
  649: # Exit:       Returns 1 if interesting, 0 otherwise.
  650: #
  651: # Side effects: None.
  652: #
  653: # Notes:      When no coverage data is available,
  654: #             keeps a random sample of inputs at
  655: #             RANDOM_KEEP_RATIO so the corpus still
  656: #             grows even without branch feedback.
  657: # --------------------------------------------------
  658: sub _is_interesting {
●659 → 662 → 667  659: 	my ($self, $coverage) = @_;
  660: 
  661: 	# Check for any newly covered branch
  662: 	for my $key (keys %{$coverage}) {
  663: 		return 1 unless $self->{covered}{$key};

  Mutants (Total: 2, Killed: 2, Survived: 0)
  664: 	}
  665: 
  666: 	# No coverage data — keep a random sample to grow the corpus
  667: 	return rand() < $RANDOM_KEEP_RATIO unless %{$coverage};

					

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

  668: 
  669: 	return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  670: }
  671: 
  672: # --------------------------------------------------
  673: # _update_covered
  674: #
  675: # Purpose:    Merge newly covered branches into the
  676: #             global covered set.
  677: #
  678: # Entry:      $coverage - hashref of branch keys.
  679: # Exit:       Returns nothing. Updates $self->{covered}.
  680: # Side effects: Modifies $self->{covered}.
  681: # --------------------------------------------------
  682: sub _update_covered {
  683: 	my ($self, $coverage) = @_;
  684: 	$self->{covered}{$_} = 1 for keys %{$coverage};
  685: }
  686: 
  687: # --------------------------------------------------
  688: # _generate_random
  689: #
  690: # Purpose:    Generate a random input value from the
  691: #             top-level schema input specification.
  692: #
  693: # Entry:      None beyond $self.
  694: # Exit:       Returns a randomly generated value.
  695: # Side effects: None.
  696: # --------------------------------------------------
  697: sub _generate_random {
  698: 	my ($self) = @_;
  699: 	return $self->_generate_for_schema($self->{schema}{input});

  Mutants (Total: 2, Killed: 2, Survived: 0)
  700: }
  701: 
  702: # --------------------------------------------------
  703: # _generate_for_schema
  704: #
  705: # Purpose:    Recursively generate a random value
  706: #             matching a schema specification hashref.
  707: #
  708: # Entry:      $spec - schema spec hashref or scalar
  709: #             type hint.
  710: #
  711: # Exit:       Returns a generated value appropriate
  712: #             for the spec type, or undef if spec is
  713: #             absent or 'undef'.
  714: #
  715: # Side effects: None.
  716: #
  717: # Notes:      Edge cases declared in edge_case_array
  718: #             are selected at EDGE_CASE_RATIO frequency
  719: #             to bias toward known interesting values.
  720: # --------------------------------------------------
  721: sub _generate_for_schema {
●722 → 730 → 736  722: 	my ($self, $spec) = @_;
  723: 
  724: 	return undef unless defined $spec;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  725: 	return undef if $spec eq 'undef';

  Mutants (Total: 2, Killed: 2, Survived: 0)
  726: 
  727: 	my $type = ref($spec) ? ($spec->{type} // $TYPE_STRING) : $TYPE_STRING;
  728: 
  729: 	# Bias toward declared edge cases at EDGE_CASE_RATIO frequency
  730: 	if(ref($spec) && $spec->{edge_case_array} && rand() < $EDGE_CASE_RATIO) {

					

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

  731: 		my @ec = @{ $spec->{edge_case_array} };
  732: 		return $ec[ int(rand(@ec)) ];

  Mutants (Total: 2, Killed: 2, Survived: 0)
  733: 	}
  734: 
  735: 	# Dispatch to type-specific generator
●736 → 736 → 0  736: 	if    ($type eq $TYPE_INTEGER) { return $self->_rand_int($spec)    }

  Mutants (Total: 3, Killed: 3, Survived: 0)
  737: 	elsif ($type eq $TYPE_NUMBER)  { return $self->_rand_num($spec)    }

					

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

  738: 	elsif ($type eq $TYPE_BOOLEAN) { return int(rand(2))               }

					

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

  739: 	elsif ($type eq $TYPE_ARRAY)   { return $self->_rand_array($spec)  }

  Mutants (Total: 2, Killed: 2, Survived: 0)
  740: 	elsif ($type eq $TYPE_HASH)    { return $self->_rand_hash($spec)   }

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

					

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

  742: }
  743: 
  744: # --------------------------------------------------
  745: # _rand_int
  746: #
  747: # Purpose:    Generate a random integer within the
  748: #             spec's min/max range, biased toward
  749: #             boundary values at INT_BOUNDARY_RATIO.
  750: #
  751: # Entry:      $spec - schema spec hashref.
  752: # Exit:       Returns an integer scalar.
  753: # Side effects: None.
  754: # --------------------------------------------------
  755: sub _rand_int {
●756 → 762 → 767  756: 	my ($self, $spec) = @_;
  757: 
  758: 	my $min = $spec->{min} // $INT32_MIN;
  759: 	my $max = $spec->{max} // $INT32_MAX;
  760: 
  761: 	# Bias toward boundary values to probe edge conditions
  762: 	if(rand() < $INT_BOUNDARY_RATIO) {

					

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

  763: 		my @interesting = ($min, $min + 1, 0, -1, 1, $max - 1, $max);
  764: 		return $interesting[ int(rand(@interesting)) ];

  Mutants (Total: 2, Killed: 2, Survived: 0)
  765: 	}
  766: 
  767: 	return $min + int(rand($max - $min + 1));

  Mutants (Total: 2, Killed: 2, Survived: 0)
  768: }
  769: 
  770: # --------------------------------------------------
  771: # _rand_num
  772: #
  773: # Purpose:    Generate a random floating point number
  774: #             within the spec's min/max range.
  775: #
  776: # Entry:      $spec - schema spec hashref.
  777: # Exit:       Returns a numeric scalar.
  778: # Side effects: None.
  779: # --------------------------------------------------
  780: sub _rand_num {
  781: 	my ($self, $spec) = @_;
  782: 
  783: 	my $min = $spec->{min} // -1e9;
  784: 	my $max = $spec->{max} //  1e9;
  785: 
  786: 	return $min + rand($max - $min);

					

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

  787: }
  788: 
  789: # --------------------------------------------------
  790: # _rand_string
  791: #
  792: # Purpose:    Generate a random string within the
  793: #             spec's min/max length range, biased
  794: #             toward boundary lengths.
  795: #
  796: # Entry:      $spec - schema spec hashref.
  797: # Exit:       Returns a string scalar.
  798: # Side effects: None.
  799: #
  800: # Notes:      Character set includes control chars
  801: #             and NUL to probe boundary handling.
  802: # --------------------------------------------------
  803: sub _rand_string {
●804 → 811 → 819  804: 	my ($self, $spec) = @_;
  805: 
  806: 	my $min_len = $spec->{min} // 0;
  807: 	my $max_len = $spec->{max} // $DEFAULT_MAX_STR_LEN;
  808: 
  809: 	# Bias toward boundary lengths at STR_BOUNDARY_RATIO frequency
  810: 	my $len;
  811: 	if(rand() < $STR_BOUNDARY_RATIO) {

					

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

  812: 		my @boundary_lens = ($min_len, $min_len + 1, $max_len - 1, $max_len);
  813: 		$len = $boundary_lens[ int(rand(@boundary_lens)) ];
  814: 	} else {
  815: 		$len = $min_len + int(rand($max_len - $min_len + 1));
  816: 	}
  817: 
  818: 	# Clamp to non-negative
  819: 	$len = 0 if $len < 0;

					

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

  820: 
  821: 	my @chars = ('a'..'z', 'A'..'Z', '0'..'9', ' ', "\t", "\n", "\0");
  822: 	return join '', map { $chars[ int(rand(@chars)) ] } 1 .. $len;

					

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

  823: }
  824: 
  825: # --------------------------------------------------
  826: # _rand_array
  827: #
  828: # Purpose:    Generate a random arrayref with 0 to
  829: #             DEFAULT_MAX_ARRAY elements, each
  830: #             generated from the items spec.
  831: #
  832: # Entry:      $spec - schema spec hashref.
  833: # Exit:       Returns an arrayref.
  834: # Side effects: None.
  835: # --------------------------------------------------
  836: sub _rand_array {
  837: 	my ($self, $spec) = @_;
  838: 
  839: 	my $items = $spec->{items} // {};
  840: 	my $count = int(rand($DEFAULT_MAX_ARRAY + 1));
  841: 
  842: 	return [ map { $self->_generate_for_schema($items) } 1 .. $count ];
  843: }
  844: 
  845: # --------------------------------------------------
  846: # _rand_hash
  847: #
  848: # Purpose:    Generate a random hashref with values
  849: #             generated from the properties spec.
  850: #
  851: # Entry:      $spec - schema spec hashref.
  852: # Exit:       Returns a hashref.
  853: # Side effects: None.
  854: # --------------------------------------------------
  855: sub _rand_hash {
●856 → 861 → 865  856: 	my ($self, $spec) = @_;
  857: 
  858: 	my $props = $spec->{properties} // {};
  859: 	my %h;
  860: 
  861: 	for my $key (keys %{$props}) {
  862: 		$h{$key} = $self->_generate_for_schema($props->{$key});
  863: 	}
  864: 
  865: 	return \%h;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  866: }
  867: 
  868: # --------------------------------------------------
  869: # _input_is_valid
  870: #
  871: # Purpose:    Return true if the input satisfies all
  872: #             constraints in the schema. Used to
  873: #             distinguish real bugs (die on valid
  874: #             input) from expected failures (die on
  875: #             invalid input).
  876: #
  877: # Entry:      $input - the value to validate.
  878: # Exit:       Returns 1 if valid, 0 if not.
  879: #             Returns 1 if no schema is available.
  880: # Side effects: None.
  881: # --------------------------------------------------
  882: sub _input_is_valid {
●883 → 892 → 896  883: 	my ($self, $input) = @_;
  884: 
  885: 	my $spec = $self->{schema}{input};
  886: 
  887: 	# No schema means we cannot judge validity
  888: 	return 1 unless defined $spec && ref($spec);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  889: 
  890: 	my $input_style = $self->{schema}{input_style} // '';
  891: 
  892: 	if($input_style eq 'hash' || ref($input) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  893: 		return $self->_validate_hash_input($input, $spec);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  894: 	}
  895: 
  896: 	return $self->_validate_value($input, $spec);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  897: }
  898: 
  899: # --------------------------------------------------
  900: # _validate_hash_input
  901: #
  902: # Purpose:    Validate a hash-style input against the
  903: #             schema spec, checking each named field.
  904: #
  905: # Entry:      $input - hashref of named parameters.
  906: #             $spec  - schema spec hashref.
  907: # Exit:       Returns 1 if valid, 0 if not.
  908: # Side effects: None.
  909: # --------------------------------------------------
  910: sub _validate_hash_input {
●911 → 915 → 934  911: 	my ($self, $input, $spec) = @_;
  912: 
  913: 	return 0 unless defined $input;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  914: 
  915: 	for my $key (keys %{$spec}) {
  916: 		# Skip internal metadata keys
  917: 		next if $key =~ /^_/;
  918: 
  919: 		my $field_spec = $spec->{$key};
  920: 		next unless ref($field_spec) eq 'HASH';
  921: 
  922: 		my $value = ref($input) eq 'HASH' ? $input->{$key} : undef;
  923: 
  924: 		# Required field missing is always invalid
  925: 		if(!defined($value) && !$field_spec->{optional}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  926: 			return 0;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  927: 		}
  928: 
  929: 		next unless defined $value;
  930: 
  931: 		return 0 unless $self->_validate_value($value, $field_spec);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  932: 	}
  933: 
  934: 	return 1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  935: }
  936: 
  937: # --------------------------------------------------
  938: # _validate_value
  939: #
  940: # Purpose:    Validate a single value against a schema
  941: #             type spec, checking type and constraints.
  942: #
  943: # Entry:      $value - the value to validate.
  944: #             $spec  - schema spec hashref.
  945: # Exit:       Returns 1 if valid, 0 if not.
  946: # Side effects: None.
  947: #
  948: # Notes:      Number validation accepts both integer
  949: #             and floating point forms including
  950: #             scientific notation. Type mismatch
  951: #             always returns 0.
  952: # --------------------------------------------------
  953: sub _validate_value {
●954 → 961 → 1005  954: 	my ($self, $value, $spec) = @_;
  955: 
  956: 	# Undef is never valid unless optional — caller already checked optional
  957: 	return 0 unless defined $value;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  958: 
  959: 	my $type = $spec->{type} // $TYPE_STRING;
  960: 
  961: 	if($type eq $TYPE_INTEGER) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  962: 		return 0 unless $value =~ /^-?\d+$/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  963: 		return 0 if defined($spec->{min}) && $value < $spec->{min};

  Mutants (Total: 5, Killed: 5, Survived: 0)
  964: 		return 0 if defined($spec->{max}) && $value > $spec->{max};

  Mutants (Total: 5, Killed: 5, Survived: 0)
  965: 	}
  966: 	elsif($type eq $TYPE_NUMBER) {
  967: 		# Accept integers, decimals, and scientific notation
  968: 		return 0 unless $value =~ /^-?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?$/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  969: 		return 0 if defined($spec->{min}) && $value < $spec->{min};

					

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

  970: 		return 0 if defined($spec->{max}) && $value > $spec->{max};

					

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

  971: 	}
  972: 	elsif($type eq $TYPE_STRING) {
  973: 		my $len = length($value);
  974: 		return 0 if defined($spec->{min}) && $len < $spec->{min};

  Mutants (Total: 5, Killed: 5, Survived: 0)
  975: 		return 0 if defined($spec->{max}) && $len > $spec->{max};

  Mutants (Total: 5, Killed: 5, Survived: 0)
  976: 		if(defined($spec->{matches})) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  977: 			(my $pat = $spec->{matches}) =~ s{^/(.+)/$}{$1};
  978: 
  979: 			# ReDoS guard: a schema-supplied pattern matched against
  980: 			# fuzzer-generated (attacker-shaped) input could exhibit
  981: 			# catastrophic backtracking. Bound the match with alarm()
  982: 			# the same way target_sub calls are bounded elsewhere in
  983: 			# this module, and treat a timeout as a non-match.
  984: 			my $matched = eval {
  985: 				local $SIG{ALRM} = sub { die "matches regex timed out\n" };
  986: 				alarm($MATCHES_REGEX_TIMEOUT_SECS);
  987: 				my $m = $value =~ /$pat/;
  988: 				alarm(0);
  989: 				$m;
  990: 			};
  991: 			alarm(0);
  992: 			return 0 unless $matched;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  993: 		}
  994: 	}
  995: 	elsif($type eq $TYPE_BOOLEAN) {
  996: 		return 0 unless $value =~ /^[01]$/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  997: 	}
  998: 	elsif($type eq $TYPE_ARRAY || $type eq 'array') {
  999: 		return 0 unless ref($value) eq 'ARRAY';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1000: 	}
 1001: 	elsif($type eq $TYPE_HASH || $type eq 'hash') {
 1002: 		return 0 unless ref($value) eq 'HASH';

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1003: 	}
 1004: 
 1005: 	return 1;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1006: }
 1007: 
 1008: # --------------------------------------------------
 1009: # _mutate
 1010: #
 1011: # Purpose:    Apply a random mutation to an input
 1012: #             value, dispatching on its type.
 1013: #
 1014: # Entry:      $input - the value to mutate.
 1015: # Exit:       Returns a mutated copy of the input.
 1016: # Side effects: None.
 1017: #
 1018: # Notes:      Blessed references are passed through
 1019: #             unchanged. Undef is replaced with a
 1020: #             freshly generated random value.
 1021: # --------------------------------------------------
 1022: sub _mutate {
●1023 → 1027 → 1049 1023: 	my ($self, $input) = @_;
 1024: 
 1025: 	my $type = ref($input);
 1026: 
 1027: 	if(!defined $input) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
 1028: 		# Replace undef with a fresh random value
 1029: 		return $self->_generate_random();

					

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

 1030: 	}
 1031: 	elsif(!$type) {
 1032: 		# Dispatch scalar mutation based on apparent type
 1033: 		if($input =~ /^-?\d+$/) {

					

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

 1034: 			return $self->_mutate_int($input);

					

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

 1035: 		} elsif($input =~ /^-?[\d.]+$/) {
 1036: 			return $self->_mutate_num($input);

					

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

 1037: 		} else {
 1038: 			return $self->_mutate_string($input);

					

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

 1039: 		}
 1040: 	}
 1041: 	elsif($type eq 'ARRAY') {
 1042: 		return $self->_mutate_array($input);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1043: 	}
 1044: 	elsif($type eq 'HASH') {
 1045: 		return $self->_mutate_hash($input);

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1046: 	}
 1047: 
 1048: 	# Blessed refs and other types pass through unchanged
 1049: 	return $input;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1050: }
 1051: 
 1052: # --------------------------------------------------
 1053: # _mutate_int
 1054: #
 1055: # Purpose:    Apply a random arithmetic mutation to
 1056: #             an integer value.
 1057: #
 1058: # Entry:      $n - the integer to mutate.
 1059: # Exit:       Returns a mutated integer.
 1060: # Side effects: None.
 1061: # --------------------------------------------------
 1062: sub _mutate_int {
 1063: 	my ($self, $n) = @_;
 1064: 
 1065: 	my @ops = (
 1066: 		sub { $n + 1              },
 1067: 		sub { $n - 1              },
 1068: 		sub { $n * 2              },
 1069: 		sub { $n == 0 ? 1 : int($n / 2) },

					

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

 1070: 		sub { -$n                 },
 1071: 		sub { 0                   },
 1072: 		sub { $INT32_MAX          },
 1073: 		sub { $INT32_MIN          },
 1074: 	);
 1075: 
 1076: 	return $ops[ int(rand(@ops)) ]->();

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1077: }
 1078: 
 1079: # --------------------------------------------------
 1080: # _mutate_num
 1081: #
 1082: # Purpose:    Apply a random arithmetic mutation to
 1083: #             a floating point value.
 1084: #
 1085: # Entry:      $n - the number to mutate.
 1086: # Exit:       Returns a mutated number.
 1087: # Side effects: None.
 1088: # --------------------------------------------------
 1089: sub _mutate_num {
 1090: 	my ($self, $n) = @_;
 1091: 
 1092: 	my @ops = (
 1093: 		sub { $n + rand(10)        },
 1094: 		sub { $n - rand(10)        },
 1095: 		sub { $n * (1 + rand())    },
 1096: 		sub { 0                    },
 1097: 		sub { -$n                  },
 1098: 	);
 1099: 
 1100: 	return $ops[ int(rand(@ops)) ]->();

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1101: }
 1102: 
 1103: # --------------------------------------------------
 1104: # _mutate_string
 1105: #
 1106: # Purpose:    Apply a random structural mutation to
 1107: #             a string value — bit flip, insert,
 1108: #             delete, truncate, repeat, or replace
 1109: #             with an interesting known value.
 1110: #
 1111: # Entry:      $s - the string to mutate.
 1112: # Exit:       Returns a mutated string.
 1113: # Side effects: None.
 1114: # --------------------------------------------------
 1115: sub _mutate_string {
 1116: 	my ($self, $s) = @_;
 1117: 
 1118: 	my $len = length($s);
 1119: 
 1120: 	my @ops = (
 1121: 		# Bit flip a random character
 1122: 		sub {
 1123: 			return $s unless $len;

					

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

 1124: 			my $pos  = int(rand($len));
 1125: 			my $char = substr($s, $pos, 1);
 1126: 			substr($s, $pos, 1) = chr(ord($char) ^ (1 << int(rand(8))));
 1127: 			$s
 1128: 		},
 1129: 		# Insert a random byte
 1130: 		sub {
 1131: 			my $pos  = int(rand($len + 1));
 1132: 			my $char = chr(int(rand(256)));
 1133: 			substr($s, $pos, 0, $char);
 1134: 			$s
 1135: 		},
 1136: 		# Delete a random character
 1137: 		sub {
 1138: 			return $s unless $len;

					

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

 1139: 			substr($s, int(rand($len)), 1, '');
 1140: 			$s
 1141: 		},
 1142: 		# Truncate at a random position
 1143: 		sub { substr($s, 0, int(rand($len + 1))) },
 1144: 		# Double the string
 1145: 		sub { $s x 2 },
 1146: 		# Replace with a known interesting string
 1147: 		sub {
 1148: 			my @interesting = (
 1149: 				'', ' ', "\0", "\n", "\t",
 1150: 				'a' x 256,
 1151: 				'null', 'undefined',
 1152: 				"'; DROP TABLE foo; --",
 1153: 				'<script>alert(1)</script>',
 1154: 			);
 1155: 			$interesting[ int(rand(@interesting)) ]
 1156: 		},
 1157: 	);
 1158: 
 1159: 	return $ops[ int(rand(@ops)) ]->();

					

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

 1160: }
 1161: 
 1162: # --------------------------------------------------
 1163: # _mutate_array
 1164: #
 1165: # Purpose:    Apply a random structural mutation to
 1166: #             an arrayref — mutate element, duplicate,
 1167: #             delete, or empty.
 1168: #
 1169: # Entry:      $arr - the arrayref to mutate.
 1170: # Exit:       Returns a mutated arrayref copy.
 1171: # Side effects: None.
 1172: # --------------------------------------------------
 1173: sub _mutate_array {
 1174: 	my ($self, $arr) = @_;
 1175: 
 1176: 	my @copy = @{$arr};
 1177: 
 1178: 	my @ops = (
 1179: 		# Mutate a random element
 1180: 		sub {
 1181: 			return [] unless @copy;
 1182: 			my $i = int(rand(@copy));
 1183: 			$copy[$i] = $self->_mutate($copy[$i]);
 1184: 			\@copy
 1185: 		},
 1186: 		# Duplicate a random element
 1187: 		sub {
 1188: 			return \@copy unless @copy;

					

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

 1189: 			my $i = int(rand(@copy));
 1190: 			splice @copy, $i, 0, $copy[$i];
 1191: 			\@copy
 1192: 		},
 1193: 		# Delete a random element
 1194: 		sub {
 1195: 			return \@copy unless @copy;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1196: 			splice @copy, int(rand(@copy)), 1;
 1197: 			\@copy
 1198: 		},
 1199: 		# Return empty array
 1200: 		sub { [] },
 1201: 	);
 1202: 
 1203: 	return $ops[ int(rand(@ops)) ]->();

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1204: }
 1205: 
 1206: # --------------------------------------------------
 1207: # _mutate_hash
 1208: #
 1209: # Purpose:    Apply a random mutation to one value
 1210: #             in a hashref copy.
 1211: #
 1212: # Entry:      $h - the hashref to mutate.
 1213: # Exit:       Returns a mutated hashref copy.
 1214: # Side effects: None.
 1215: # --------------------------------------------------
 1216: sub _mutate_hash {
 1217: 	my ($self, $h) = @_;
 1218: 
 1219: 	my %copy = %{$h};
 1220: 	my @keys = keys %copy;
 1221: 
 1222: 	# Return unchanged if hash is empty
 1223: 	return \%copy unless @keys;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1224: 
 1225: 	my $k = $keys[ int(rand(@keys)) ];
 1226: 	$copy{$k} = $self->_mutate($copy{$k});
 1227: 
 1228: 	return \%copy;

  Mutants (Total: 2, Killed: 2, Survived: 0)
 1229: }
 1230: 
 1231: # --------------------------------------------------
 1232: # _seed_corpus
 1233: #
 1234: # Purpose:    Pre-populate the corpus with a small
 1235: #             set of randomly generated inputs to
 1236: #             give the fuzzing loop a starting point.
 1237: #
 1238: # Entry:      None beyond $self.
 1239: # Exit:       Returns nothing. Appends to $self->{corpus}.
 1240: # Side effects: Modifies $self->{corpus}.
 1241: # --------------------------------------------------
 1242: sub _seed_corpus {
●1243 → 1245 → 0 1243: 	my $self = $_[0];
 1244: 
 1245: 	for (1 .. $SEED_CORPUS_SIZE) {
 1246: 		push @{ $self->{corpus} }, {
 1247: 			input    => $self->_generate_random(),
 1248: 			coverage => {},
 1249: 		};
 1250: 	}
 1251: }
 1252: 
 1253: # --------------------------------------------------
 1254: # _build_report
 1255: #
 1256: # Purpose:    Construct the summary report hashref
 1257: #             returned by run().
 1258: #
 1259: # Entry:      None beyond $self.
 1260: # Exit:       Returns a report hashref.
 1261: # Side effects: None.
 1262: # --------------------------------------------------
 1263: sub _build_report {
 1264: 	my $self = $_[0];
 1265: 
 1266: 	return {
 1267: 		total_iterations   => $self->{stats}{total},
 1268: 		interesting_inputs => $self->{stats}{interesting},
 1269: 		corpus_size        => scalar @{ $self->{corpus} },
 1270: 		branches_covered   => $self->{stats}{coverage},
 1271: 		bugs_found         => $self->{stats}{bugs},
 1272: 		bugs               => $self->{bugs},
 1273: 	};
 1274: }
 1275: 
 1276: =head1 AUTHOR
 1277: 
 1278: Nigel Horne, C<< <njh at nigelhorne.com> >>
 1279: 
 1280: Portions of this module's initial design and documentation were created
 1281: with the assistance of AI.
 1282: 
 1283: =head1 LICENCE AND COPYRIGHT
 1284: 
 1285: Copyright 2026 Nigel Horne.
 1286: 
 1287: Usage is subject to GPL2 licence terms.
 1288: If you use it,
 1289: please let me know.
 1290: 
 1291: =cut
 1292: 
 1293: 1;